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
84 # define yylex(a,b) Perl_yylex(aTHX_ a, b)
86 # define PERL_YYLEX_PARAM
94 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
96 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
97 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
98 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
99 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
100 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
101 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
102 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
103 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
104 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
105 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
106 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
107 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
108 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
109 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
110 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
111 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
112 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
113 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
114 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
115 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
117 /* This bit of chicanery makes a unary function followed by
118 * a parenthesis into a function with one argument, highest precedence.
120 #define UNI(f) return(yylval.ival = f, \
123 PL_last_uni = PL_oldbufptr, \
124 PL_last_lop_op = f, \
125 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
127 #define UNIBRACK(f) return(yylval.ival = f, \
129 PL_last_uni = PL_oldbufptr, \
130 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
132 /* grandfather return to old style */
133 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
136 ao(pTHX_ int toketype)
138 if (*PL_bufptr == '=') {
140 if (toketype == ANDAND)
141 yylval.ival = OP_ANDASSIGN;
142 else if (toketype == OROR)
143 yylval.ival = OP_ORASSIGN;
150 no_op(pTHX_ char *what, char *s)
152 char *oldbp = PL_bufptr;
153 bool is_first = (PL_oldbufptr == PL_linestart);
156 yywarn(form("%s found where operator expected", what));
158 warn("\t(Missing semicolon on previous line?)\n");
159 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
161 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
162 if (t < PL_bufptr && isSPACE(*t))
163 warn("\t(Do you need to predeclare %.*s?)\n",
164 t - PL_oldoldbufptr, PL_oldoldbufptr);
168 warn("\t(Missing operator before end of line?)\n");
170 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
175 missingterm(pTHX_ char *s)
180 char *nl = strrchr(s,'\n');
186 iscntrl(PL_multi_close)
188 PL_multi_close < 32 || PL_multi_close == 127
192 tmpbuf[1] = toCTRL(PL_multi_close);
198 *tmpbuf = PL_multi_close;
202 q = strchr(s,'"') ? '\'' : '"';
203 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
207 Perl_deprecate(pTHX_ char *s)
210 if (ckWARN(WARN_DEPRECATED))
211 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
217 deprecate("comma-less variable list");
223 win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
225 I32 count = FILTER_READ(idx+1, sv, maxlen);
226 if (count > 0 && !maxlen)
227 win32_strip_return(sv);
233 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
235 I32 count = FILTER_READ(idx+1, sv, maxlen);
239 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
240 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
241 sv_usepvn(sv, (char*)tmps, tend - tmps);
248 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
250 I32 count = FILTER_READ(idx+1, sv, maxlen);
254 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
255 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
256 sv_usepvn(sv, (char*)tmps, tend - tmps);
263 Perl_lex_start(pTHX_ SV *line)
269 SAVEI32(PL_lex_dojoin);
270 SAVEI32(PL_lex_brackets);
271 SAVEI32(PL_lex_fakebrack);
272 SAVEI32(PL_lex_casemods);
273 SAVEI32(PL_lex_starts);
274 SAVEI32(PL_lex_state);
275 SAVESPTR(PL_lex_inpat);
276 SAVEI32(PL_lex_inwhat);
277 SAVEI16(PL_curcop->cop_line);
280 SAVEPPTR(PL_oldbufptr);
281 SAVEPPTR(PL_oldoldbufptr);
282 SAVEPPTR(PL_linestart);
283 SAVESPTR(PL_linestr);
284 SAVEPPTR(PL_lex_brackstack);
285 SAVEPPTR(PL_lex_casestack);
286 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
287 SAVESPTR(PL_lex_stuff);
288 SAVEI32(PL_lex_defer);
289 SAVESPTR(PL_lex_repl);
290 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
291 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
293 PL_lex_state = LEX_NORMAL;
297 PL_lex_fakebrack = 0;
298 New(899, PL_lex_brackstack, 120, char);
299 New(899, PL_lex_casestack, 12, char);
300 SAVEFREEPV(PL_lex_brackstack);
301 SAVEFREEPV(PL_lex_casestack);
303 *PL_lex_casestack = '\0';
306 PL_lex_stuff = Nullsv;
307 PL_lex_repl = Nullsv;
311 if (SvREADONLY(PL_linestr))
312 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
313 s = SvPV(PL_linestr, len);
314 if (len && s[len-1] != ';') {
315 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
316 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
317 sv_catpvn(PL_linestr, "\n;", 2);
319 SvTEMP_off(PL_linestr);
320 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
321 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
323 PL_rs = newSVpvn("\n", 1);
330 PL_doextract = FALSE;
334 restore_rsfp(pTHX_ void *f)
336 PerlIO *fp = (PerlIO*)f;
338 if (PL_rsfp == PerlIO_stdin())
339 PerlIO_clearerr(PL_rsfp);
340 else if (PL_rsfp && (PL_rsfp != fp))
341 PerlIO_close(PL_rsfp);
346 restore_expect(pTHX_ void *e)
348 /* a safe way to store a small integer in a pointer */
349 PL_expect = (expectation)((char *)e - PL_tokenbuf);
353 restore_lex_expect(pTHX_ void *e)
355 /* a safe way to store a small integer in a pointer */
356 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
360 incline(pTHX_ char *s)
368 PL_curcop->cop_line++;
371 while (*s == ' ' || *s == '\t') s++;
372 if (strnEQ(s, "line ", 5)) {
381 while (*s == ' ' || *s == '\t')
383 if (*s == '"' && (t = strchr(s+1, '"')))
387 return; /* false alarm */
388 for (t = s; !isSPACE(*t); t++) ;
393 PL_curcop->cop_filegv = gv_fetchfile(s);
395 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
397 PL_curcop->cop_line = atoi(n)-1;
401 skipspace(pTHX_ register char *s)
404 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
405 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
411 while (s < PL_bufend && isSPACE(*s)) {
412 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
415 if (s < PL_bufend && *s == '#') {
416 while (s < PL_bufend && *s != '\n')
420 if (PL_in_eval && !PL_rsfp) {
426 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
428 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
429 if (PL_minus_n || PL_minus_p) {
430 sv_setpv(PL_linestr,PL_minus_p ?
431 ";}continue{print or die qq(-p destination: $!\\n)" :
433 sv_catpv(PL_linestr,";}");
434 PL_minus_n = PL_minus_p = 0;
437 sv_setpv(PL_linestr,";");
438 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
439 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
440 if (PL_preprocess && !PL_in_eval)
441 (void)PerlProc_pclose(PL_rsfp);
442 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
443 PerlIO_clearerr(PL_rsfp);
445 (void)PerlIO_close(PL_rsfp);
449 PL_linestart = PL_bufptr = s + prevlen;
450 PL_bufend = s + SvCUR(PL_linestr);
453 if (PERLDB_LINE && PL_curstash != PL_debstash) {
454 SV *sv = NEWSV(85,0);
456 sv_upgrade(sv, SVt_PVMG);
457 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
458 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
470 if (PL_oldoldbufptr != PL_last_uni)
472 while (isSPACE(*PL_last_uni))
474 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
475 if ((t = strchr(s, '(')) && t < PL_bufptr)
479 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
486 #define UNI(f) return uni(f,s)
489 uni(pTHX_ I32 f, char *s)
494 PL_last_uni = PL_oldbufptr;
505 #endif /* CRIPPLED_CC */
507 #define LOP(f,x) return lop(f,x,s)
510 lop(pTHX_ I32 f, expectation x, char *s)
517 PL_last_lop = PL_oldbufptr;
531 force_next(pTHX_ I32 type)
533 PL_nexttype[PL_nexttoke] = type;
535 if (PL_lex_state != LEX_KNOWNEXT) {
536 PL_lex_defer = PL_lex_state;
537 PL_lex_expect = PL_expect;
538 PL_lex_state = LEX_KNOWNEXT;
543 force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
548 start = skipspace(start);
550 if (isIDFIRST_lazy(s) ||
551 (allow_pack && *s == ':') ||
552 (allow_initial_tick && *s == '\'') )
554 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
555 if (check_keyword && keyword(PL_tokenbuf, len))
557 if (token == METHOD) {
562 PL_expect = XOPERATOR;
565 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
566 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
573 force_ident(pTHX_ register char *s, int kind)
576 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
577 PL_nextval[PL_nexttoke].opval = o;
580 dTHR; /* just for in_eval */
581 o->op_private = OPpCONST_ENTERED;
582 /* XXX see note in pp_entereval() for why we forgo typo
583 warnings if the symbol must be introduced in an eval.
585 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
586 kind == '$' ? SVt_PV :
587 kind == '@' ? SVt_PVAV :
588 kind == '%' ? SVt_PVHV :
596 force_version(pTHX_ char *s)
598 OP *version = Nullop;
602 /* default VERSION number -- GBARR */
607 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
608 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
610 /* real VERSION number -- GBARR */
611 version = yylval.opval;
615 /* NOTE: The parser sees the package name and the VERSION swapped */
616 PL_nextval[PL_nexttoke].opval = version;
634 s = SvPV_force(sv, len);
638 while (s < send && *s != '\\')
643 if ( PL_hints & HINT_NEW_STRING )
644 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
647 if (s + 1 < send && (s[1] == '\\'))
648 s++; /* all that, just for this */
653 SvCUR_set(sv, d - SvPVX(sv));
655 if ( PL_hints & HINT_NEW_STRING )
656 return new_constant(NULL, 0, "q", sv, pv, "q");
663 register I32 op_type = yylval.ival;
665 if (op_type == OP_NULL) {
666 yylval.opval = PL_lex_op;
670 if (op_type == OP_CONST || op_type == OP_READLINE) {
671 SV *sv = tokeq(PL_lex_stuff);
673 if (SvTYPE(sv) == SVt_PVIV) {
674 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
680 nsv = newSVpvn(p, len);
684 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
685 PL_lex_stuff = Nullsv;
689 PL_sublex_info.super_state = PL_lex_state;
690 PL_sublex_info.sub_inwhat = op_type;
691 PL_sublex_info.sub_op = PL_lex_op;
692 PL_lex_state = LEX_INTERPPUSH;
696 yylval.opval = PL_lex_op;
710 PL_lex_state = PL_sublex_info.super_state;
711 SAVEI32(PL_lex_dojoin);
712 SAVEI32(PL_lex_brackets);
713 SAVEI32(PL_lex_fakebrack);
714 SAVEI32(PL_lex_casemods);
715 SAVEI32(PL_lex_starts);
716 SAVEI32(PL_lex_state);
717 SAVESPTR(PL_lex_inpat);
718 SAVEI32(PL_lex_inwhat);
719 SAVEI16(PL_curcop->cop_line);
721 SAVEPPTR(PL_oldbufptr);
722 SAVEPPTR(PL_oldoldbufptr);
723 SAVEPPTR(PL_linestart);
724 SAVESPTR(PL_linestr);
725 SAVEPPTR(PL_lex_brackstack);
726 SAVEPPTR(PL_lex_casestack);
728 PL_linestr = PL_lex_stuff;
729 PL_lex_stuff = Nullsv;
731 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
732 PL_bufend += SvCUR(PL_linestr);
733 SAVEFREESV(PL_linestr);
735 PL_lex_dojoin = FALSE;
737 PL_lex_fakebrack = 0;
738 New(899, PL_lex_brackstack, 120, char);
739 New(899, PL_lex_casestack, 12, char);
740 SAVEFREEPV(PL_lex_brackstack);
741 SAVEFREEPV(PL_lex_casestack);
743 *PL_lex_casestack = '\0';
745 PL_lex_state = LEX_INTERPCONCAT;
746 PL_curcop->cop_line = PL_multi_start;
748 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
749 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
750 PL_lex_inpat = PL_sublex_info.sub_op;
752 PL_lex_inpat = Nullop;
760 if (!PL_lex_starts++) {
761 PL_expect = XOPERATOR;
762 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
766 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
767 PL_lex_state = LEX_INTERPCASEMOD;
768 return yylex(PERL_YYLEX_PARAM);
771 /* Is there a right-hand side to take care of? */
772 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
773 PL_linestr = PL_lex_repl;
775 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
776 PL_bufend += SvCUR(PL_linestr);
777 SAVEFREESV(PL_linestr);
778 PL_lex_dojoin = FALSE;
780 PL_lex_fakebrack = 0;
782 *PL_lex_casestack = '\0';
784 if (SvEVALED(PL_lex_repl)) {
785 PL_lex_state = LEX_INTERPNORMAL;
787 /* we don't clear PL_lex_repl here, so that we can check later
788 whether this is an evalled subst; that means we rely on the
789 logic to ensure sublex_done() is called again only via the
790 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
793 PL_lex_state = LEX_INTERPCONCAT;
794 PL_lex_repl = Nullsv;
800 PL_bufend = SvPVX(PL_linestr);
801 PL_bufend += SvCUR(PL_linestr);
802 PL_expect = XOPERATOR;
810 Extracts a pattern, double-quoted string, or transliteration. This
813 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
814 processing a pattern (PL_lex_inpat is true), a transliteration
815 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
817 Returns a pointer to the character scanned up to. Iff this is
818 advanced from the start pointer supplied (ie if anything was
819 successfully parsed), will leave an OP for the substring scanned
820 in yylval. Caller must intuit reason for not parsing further
821 by looking at the next characters herself.
825 double-quoted style: \r and \n
826 regexp special ones: \D \s
828 backrefs: \1 (deprecated in substitution replacements)
829 case and quoting: \U \Q \E
830 stops on @ and $, but not for $ as tail anchor
833 characters are VERY literal, except for - not at the start or end
834 of the string, which indicates a range. scan_const expands the
835 range to the full set of intermediate characters.
837 In double-quoted strings:
839 double-quoted style: \r and \n
841 backrefs: \1 (deprecated)
842 case and quoting: \U \Q \E
845 scan_const does *not* construct ops to handle interpolated strings.
846 It stops processing as soon as it finds an embedded $ or @ variable
847 and leaves it to the caller to work out what's going on.
849 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
851 $ in pattern could be $foo or could be tail anchor. Assumption:
852 it's a tail anchor if $ is the last thing in the string, or if it's
853 followed by one of ")| \n\t"
855 \1 (backreferences) are turned into $1
857 The structure of the code is
858 while (there's a character to process) {
859 handle transliteration ranges
861 skip # initiated comments in //x patterns
862 check for embedded @foo
863 check for embedded scalars
865 leave intact backslashes from leave (below)
866 deprecate \1 in strings and sub replacements
867 handle string-changing backslashes \l \U \Q \E, etc.
868 switch (what was escaped) {
869 handle - in a transliteration (becomes a literal -)
870 handle \132 octal characters
871 handle 0x15 hex characters
872 handle \cV (control V)
873 handle printf backslashes (\f, \r, \n, etc)
876 } (end while character to read)
881 scan_const(pTHX_ char *start)
883 register char *send = PL_bufend; /* end of the constant */
884 SV *sv = NEWSV(93, send - start); /* sv for the constant */
885 register char *s = start; /* start of the constant */
886 register char *d = SvPVX(sv); /* destination for copies */
887 bool dorange = FALSE; /* are we in a translit range? */
889 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
890 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
892 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
893 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
896 /* leaveit is the set of acceptably-backslashed characters */
899 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
902 while (s < send || dorange) {
903 /* get transliterations out of the way (they're most literal) */
904 if (PL_lex_inwhat == OP_TRANS) {
905 /* expand a range A-Z to the full set of characters. AIE! */
907 I32 i; /* current expanded character */
908 I32 min; /* first character in range */
909 I32 max; /* last character in range */
911 i = d - SvPVX(sv); /* remember current offset */
912 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
913 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
914 d -= 2; /* eat the first char and the - */
916 min = (U8)*d; /* first char in range */
917 max = (U8)d[1]; /* last char in range */
920 if ((isLOWER(min) && isLOWER(max)) ||
921 (isUPPER(min) && isUPPER(max))) {
923 for (i = min; i <= max; i++)
927 for (i = min; i <= max; i++)
934 for (i = min; i <= max; i++)
937 /* mark the range as done, and continue */
942 /* range begins (ignore - as first or last char) */
943 else if (*s == '-' && s+1 < send && s != start) {
945 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
954 /* if we get here, we're not doing a transliteration */
956 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
957 except for the last char, which will be done separately. */
958 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
960 while (s < send && *s != ')')
962 } else if (s[2] == '{'
963 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
965 char *regparse = s + (s[2] == '{' ? 3 : 4);
968 while (count && (c = *regparse)) {
969 if (c == '\\' && regparse[1])
977 if (*regparse != ')') {
978 regparse--; /* Leave one char for continuation. */
979 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
986 /* likewise skip #-initiated comments in //x patterns */
987 else if (*s == '#' && PL_lex_inpat &&
988 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
989 while (s+1 < send && *s != '\n')
993 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
994 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
997 /* check for embedded scalars. only stop if we're sure it's a
1000 else if (*s == '$') {
1001 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1003 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1004 break; /* in regexp, $ might be tail anchor */
1007 /* (now in tr/// code again) */
1009 if (*s & 0x80 && thisutf) {
1010 dTHR; /* only for ckWARN */
1011 if (ckWARN(WARN_UTF8)) {
1012 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1022 if (*s == '\\' && s+1 < send) {
1025 /* some backslashes we leave behind */
1026 if (*leaveit && *s && strchr(leaveit, *s)) {
1032 /* deprecate \1 in strings and substitution replacements */
1033 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1034 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1036 dTHR; /* only for ckWARN */
1037 if (ckWARN(WARN_SYNTAX))
1038 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1043 /* string-change backslash escapes */
1044 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1049 /* if we get here, it's either a quoted -, or a digit */
1052 /* quoted - in transliterations */
1054 if (PL_lex_inwhat == OP_TRANS) {
1062 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1064 "Unrecognized escape \\%c passed through",
1066 /* default action is to copy the quoted character */
1071 /* \132 indicates an octal constant */
1072 case '0': case '1': case '2': case '3':
1073 case '4': case '5': case '6': case '7':
1074 *d++ = scan_oct(s, 3, &len);
1078 /* \x24 indicates a hex constant */
1082 char* e = strchr(s, '}');
1085 yyerror("Missing right brace on \\x{}");
1090 if (ckWARN(WARN_UTF8))
1092 "Use of \\x{} without utf8 declaration");
1094 /* note: utf always shorter than hex */
1095 d = (char*)uv_to_utf8((U8*)d,
1096 scan_hex(s + 1, e - s - 1, &len));
1101 UV uv = (UV)scan_hex(s, 2, &len);
1102 if (utf && PL_lex_inwhat == OP_TRANS &&
1103 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1105 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1108 if (uv >= 127 && UTF) {
1110 if (ckWARN(WARN_UTF8))
1112 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1121 /* \c is a control character */
1135 /* printf-style backslashes, formfeeds, newlines, etc */
1161 } /* end if (backslash) */
1164 } /* while loop to process each character */
1166 /* terminate the string and set up the sv */
1168 SvCUR_set(sv, d - SvPVX(sv));
1171 /* shrink the sv if we allocated more than we used */
1172 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1173 SvLEN_set(sv, SvCUR(sv) + 1);
1174 Renew(SvPVX(sv), SvLEN(sv), char);
1177 /* return the substring (via yylval) only if we parsed anything */
1178 if (s > PL_bufptr) {
1179 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1180 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1182 ( PL_lex_inwhat == OP_TRANS
1184 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1187 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1193 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1195 intuit_more(pTHX_ register char *s)
1197 if (PL_lex_brackets)
1199 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1201 if (*s != '{' && *s != '[')
1206 /* In a pattern, so maybe we have {n,m}. */
1223 /* On the other hand, maybe we have a character class */
1226 if (*s == ']' || *s == '^')
1229 int weight = 2; /* let's weigh the evidence */
1231 unsigned char un_char = 255, last_un_char;
1232 char *send = strchr(s,']');
1233 char tmpbuf[sizeof PL_tokenbuf * 4];
1235 if (!send) /* has to be an expression */
1238 Zero(seen,256,char);
1241 else if (isDIGIT(*s)) {
1243 if (isDIGIT(s[1]) && s[2] == ']')
1249 for (; s < send; s++) {
1250 last_un_char = un_char;
1251 un_char = (unsigned char)*s;
1256 weight -= seen[un_char] * 10;
1257 if (isALNUM_lazy(s+1)) {
1258 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1259 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1264 else if (*s == '$' && s[1] &&
1265 strchr("[#!%*<>()-=",s[1])) {
1266 if (/*{*/ strchr("])} =",s[2]))
1275 if (strchr("wds]",s[1]))
1277 else if (seen['\''] || seen['"'])
1279 else if (strchr("rnftbxcav",s[1]))
1281 else if (isDIGIT(s[1])) {
1283 while (s[1] && isDIGIT(s[1]))
1293 if (strchr("aA01! ",last_un_char))
1295 if (strchr("zZ79~",s[1]))
1297 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1298 weight -= 5; /* cope with negative subscript */
1301 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1302 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1307 if (keyword(tmpbuf, d - tmpbuf))
1310 if (un_char == last_un_char + 1)
1312 weight -= seen[un_char];
1317 if (weight >= 0) /* probably a character class */
1325 intuit_method(pTHX_ char *start, GV *gv)
1327 char *s = start + (*start == '$');
1328 char tmpbuf[sizeof PL_tokenbuf];
1336 if ((cv = GvCVu(gv))) {
1337 char *proto = SvPVX(cv);
1347 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1348 if (*start == '$') {
1349 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1354 return *s == '(' ? FUNCMETH : METHOD;
1356 if (!keyword(tmpbuf, len)) {
1357 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1362 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1363 if (indirgv && GvCVu(indirgv))
1365 /* filehandle or package name makes it a method */
1366 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1368 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1369 return 0; /* no assumptions -- "=>" quotes bearword */
1371 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1372 newSVpvn(tmpbuf,len));
1373 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1377 return *s == '(' ? FUNCMETH : METHOD;
1387 char *pdb = PerlEnv_getenv("PERL5DB");
1391 SETERRNO(0,SS$_NORMAL);
1392 return "BEGIN { require 'perl5db.pl' }";
1398 /* Encoded script support. filter_add() effectively inserts a
1399 * 'pre-processing' function into the current source input stream.
1400 * Note that the filter function only applies to the current source file
1401 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1403 * The datasv parameter (which may be NULL) can be used to pass
1404 * private data to this instance of the filter. The filter function
1405 * can recover the SV using the FILTER_DATA macro and use it to
1406 * store private buffers and state information.
1408 * The supplied datasv parameter is upgraded to a PVIO type
1409 * and the IoDIRP field is used to store the function pointer.
1410 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1411 * private use must be set using malloc'd pointers.
1415 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1417 if (!funcp){ /* temporary handy debugging hack to be deleted */
1418 PL_filter_debug = atoi((char*)datasv);
1421 if (!PL_rsfp_filters)
1422 PL_rsfp_filters = newAV();
1424 datasv = NEWSV(255,0);
1425 if (!SvUPGRADE(datasv, SVt_PVIO))
1426 die("Can't upgrade filter_add data to SVt_PVIO");
1427 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1428 if (PL_filter_debug) {
1430 warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1432 av_unshift(PL_rsfp_filters, 1);
1433 av_store(PL_rsfp_filters, 0, datasv) ;
1438 /* Delete most recently added instance of this filter function. */
1440 Perl_filter_del(pTHX_ filter_t funcp)
1442 if (PL_filter_debug)
1443 warn("filter_del func %p", funcp);
1444 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1446 /* if filter is on top of stack (usual case) just pop it off */
1447 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1448 IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1449 sv_free(av_pop(PL_rsfp_filters));
1453 /* we need to search for the correct entry and clear it */
1454 die("filter_del can only delete in reverse order (currently)");
1458 /* Invoke the n'th filter function for the current rsfp. */
1460 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1463 /* 0 = read one text line */
1468 if (!PL_rsfp_filters)
1470 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1471 /* Provide a default input filter to make life easy. */
1472 /* Note that we append to the line. This is handy. */
1473 if (PL_filter_debug)
1474 warn("filter_read %d: from rsfp\n", idx);
1478 int old_len = SvCUR(buf_sv) ;
1480 /* ensure buf_sv is large enough */
1481 SvGROW(buf_sv, old_len + maxlen) ;
1482 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1483 if (PerlIO_error(PL_rsfp))
1484 return -1; /* error */
1486 return 0 ; /* end of file */
1488 SvCUR_set(buf_sv, old_len + len) ;
1491 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1492 if (PerlIO_error(PL_rsfp))
1493 return -1; /* error */
1495 return 0 ; /* end of file */
1498 return SvCUR(buf_sv);
1500 /* Skip this filter slot if filter has been deleted */
1501 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1502 if (PL_filter_debug)
1503 warn("filter_read %d: skipped (filter deleted)\n", idx);
1504 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1506 /* Get function pointer hidden within datasv */
1507 funcp = (filter_t)IoDIRP(datasv);
1508 if (PL_filter_debug) {
1510 warn("filter_read %d: via function %p (%s)\n",
1511 idx, funcp, SvPV(datasv,n_a));
1513 /* Call function. The function is expected to */
1514 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1515 /* Return: <0:error, =0:eof, >0:not eof */
1516 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1520 filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1523 if (!PL_rsfp_filters) {
1524 filter_add(win32_textfilter,NULL);
1527 if (PL_rsfp_filters) {
1530 SvCUR_set(sv, 0); /* start with empty line */
1531 if (FILTER_READ(0, sv, 0) > 0)
1532 return ( SvPVX(sv) ) ;
1537 return (sv_gets(sv, fp, append));
1542 static char* exp_name[] =
1543 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1549 Works out what to call the token just pulled out of the input
1550 stream. The yacc parser takes care of taking the ops we return and
1551 stitching them into a tree.
1557 if read an identifier
1558 if we're in a my declaration
1559 croak if they tried to say my($foo::bar)
1560 build the ops for a my() declaration
1561 if it's an access to a my() variable
1562 are we in a sort block?
1563 croak if my($a); $a <=> $b
1564 build ops for access to a my() variable
1565 if in a dq string, and they've said @foo and we can't find @foo
1567 build ops for a bareword
1568 if we already built the token before, use it.
1572 #ifdef USE_PURE_BISON
1573 yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1586 #ifdef USE_PURE_BISON
1587 yylval_pointer = lvalp;
1588 yychar_pointer = lcharp;
1591 /* check if there's an identifier for us to look at */
1592 if (PL_pending_ident) {
1593 /* pit holds the identifier we read and pending_ident is reset */
1594 char pit = PL_pending_ident;
1595 PL_pending_ident = 0;
1597 /* if we're in a my(), we can't allow dynamics here.
1598 $foo'bar has already been turned into $foo::bar, so
1599 just check for colons.
1601 if it's a legal name, the OP is a PADANY.
1604 if (strchr(PL_tokenbuf,':'))
1605 yyerror(form(PL_no_myglob,PL_tokenbuf));
1607 yylval.opval = newOP(OP_PADANY, 0);
1608 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1613 build the ops for accesses to a my() variable.
1615 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1616 then used in a comparison. This catches most, but not
1617 all cases. For instance, it catches
1618 sort { my($a); $a <=> $b }
1620 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1621 (although why you'd do that is anyone's guess).
1624 if (!strchr(PL_tokenbuf,':')) {
1626 /* Check for single character per-thread SVs */
1627 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1628 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1629 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1631 yylval.opval = newOP(OP_THREADSV, 0);
1632 yylval.opval->op_targ = tmp;
1635 #endif /* USE_THREADS */
1636 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1637 /* if it's a sort block and they're naming $a or $b */
1638 if (PL_last_lop_op == OP_SORT &&
1639 PL_tokenbuf[0] == '$' &&
1640 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1643 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1644 d < PL_bufend && *d != '\n';
1647 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1648 croak("Can't use \"my %s\" in sort comparison",
1654 yylval.opval = newOP(OP_PADANY, 0);
1655 yylval.opval->op_targ = tmp;
1661 Whine if they've said @foo in a doublequoted string,
1662 and @foo isn't a variable we can find in the symbol
1665 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1666 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1667 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1668 yyerror(form("In string, %s now must be written as \\%s",
1669 PL_tokenbuf, PL_tokenbuf));
1672 /* build ops for a bareword */
1673 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1674 yylval.opval->op_private = OPpCONST_ENTERED;
1675 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1676 ((PL_tokenbuf[0] == '$') ? SVt_PV
1677 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1682 /* no identifier pending identification */
1684 switch (PL_lex_state) {
1686 case LEX_NORMAL: /* Some compilers will produce faster */
1687 case LEX_INTERPNORMAL: /* code if we comment these out. */
1691 /* when we're already built the next token, just pull it out the queue */
1694 yylval = PL_nextval[PL_nexttoke];
1696 PL_lex_state = PL_lex_defer;
1697 PL_expect = PL_lex_expect;
1698 PL_lex_defer = LEX_NORMAL;
1700 return(PL_nexttype[PL_nexttoke]);
1702 /* interpolated case modifiers like \L \U, including \Q and \E.
1703 when we get here, PL_bufptr is at the \
1705 case LEX_INTERPCASEMOD:
1707 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1708 croak("panic: INTERPCASEMOD");
1710 /* handle \E or end of string */
1711 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1715 if (PL_lex_casemods) {
1716 oldmod = PL_lex_casestack[--PL_lex_casemods];
1717 PL_lex_casestack[PL_lex_casemods] = '\0';
1719 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1721 PL_lex_state = LEX_INTERPCONCAT;
1725 if (PL_bufptr != PL_bufend)
1727 PL_lex_state = LEX_INTERPCONCAT;
1728 return yylex(PERL_YYLEX_PARAM);
1732 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1733 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1734 if (strchr("LU", *s) &&
1735 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1737 PL_lex_casestack[--PL_lex_casemods] = '\0';
1740 if (PL_lex_casemods > 10) {
1741 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1742 if (newlb != PL_lex_casestack) {
1744 PL_lex_casestack = newlb;
1747 PL_lex_casestack[PL_lex_casemods++] = *s;
1748 PL_lex_casestack[PL_lex_casemods] = '\0';
1749 PL_lex_state = LEX_INTERPCONCAT;
1750 PL_nextval[PL_nexttoke].ival = 0;
1753 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1755 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1757 PL_nextval[PL_nexttoke].ival = OP_LC;
1759 PL_nextval[PL_nexttoke].ival = OP_UC;
1761 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1763 croak("panic: yylex");
1766 if (PL_lex_starts) {
1772 return yylex(PERL_YYLEX_PARAM);
1775 case LEX_INTERPPUSH:
1776 return sublex_push();
1778 case LEX_INTERPSTART:
1779 if (PL_bufptr == PL_bufend)
1780 return sublex_done();
1782 PL_lex_dojoin = (*PL_bufptr == '@');
1783 PL_lex_state = LEX_INTERPNORMAL;
1784 if (PL_lex_dojoin) {
1785 PL_nextval[PL_nexttoke].ival = 0;
1788 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1789 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1790 force_next(PRIVATEREF);
1792 force_ident("\"", '$');
1793 #endif /* USE_THREADS */
1794 PL_nextval[PL_nexttoke].ival = 0;
1796 PL_nextval[PL_nexttoke].ival = 0;
1798 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1801 if (PL_lex_starts++) {
1805 return yylex(PERL_YYLEX_PARAM);
1807 case LEX_INTERPENDMAYBE:
1808 if (intuit_more(PL_bufptr)) {
1809 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1815 if (PL_lex_dojoin) {
1816 PL_lex_dojoin = FALSE;
1817 PL_lex_state = LEX_INTERPCONCAT;
1820 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
1821 && SvEVALED(PL_lex_repl))
1823 if (PL_bufptr != PL_bufend)
1824 croak("Bad evalled substitution pattern");
1825 PL_lex_repl = Nullsv;
1828 case LEX_INTERPCONCAT:
1830 if (PL_lex_brackets)
1831 croak("panic: INTERPCONCAT");
1833 if (PL_bufptr == PL_bufend)
1834 return sublex_done();
1836 if (SvIVX(PL_linestr) == '\'') {
1837 SV *sv = newSVsv(PL_linestr);
1840 else if ( PL_hints & HINT_NEW_RE )
1841 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1842 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1846 s = scan_const(PL_bufptr);
1848 PL_lex_state = LEX_INTERPCASEMOD;
1850 PL_lex_state = LEX_INTERPSTART;
1853 if (s != PL_bufptr) {
1854 PL_nextval[PL_nexttoke] = yylval;
1857 if (PL_lex_starts++)
1861 return yylex(PERL_YYLEX_PARAM);
1865 return yylex(PERL_YYLEX_PARAM);
1867 PL_lex_state = LEX_NORMAL;
1868 s = scan_formline(PL_bufptr);
1869 if (!PL_lex_formbrack)
1875 PL_oldoldbufptr = PL_oldbufptr;
1878 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1884 if (isIDFIRST_lazy(s))
1886 croak("Unrecognized character \\x%02X", *s & 255);
1889 goto fake_eof; /* emulate EOF on ^D or ^Z */
1894 if (PL_lex_brackets)
1895 yyerror("Missing right curly or square bracket");
1898 if (s++ < PL_bufend)
1899 goto retry; /* ignore stray nulls */
1902 if (!PL_in_eval && !PL_preambled) {
1903 PL_preambled = TRUE;
1904 sv_setpv(PL_linestr,incl_perldb());
1905 if (SvCUR(PL_linestr))
1906 sv_catpv(PL_linestr,";");
1908 while(AvFILLp(PL_preambleav) >= 0) {
1909 SV *tmpsv = av_shift(PL_preambleav);
1910 sv_catsv(PL_linestr, tmpsv);
1911 sv_catpv(PL_linestr, ";");
1914 sv_free((SV*)PL_preambleav);
1915 PL_preambleav = NULL;
1917 if (PL_minus_n || PL_minus_p) {
1918 sv_catpv(PL_linestr, "LINE: while (<>) {");
1920 sv_catpv(PL_linestr,"chomp;");
1922 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1924 GvIMPORTED_AV_on(gv);
1926 if (strchr("/'\"", *PL_splitstr)
1927 && strchr(PL_splitstr + 1, *PL_splitstr))
1928 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1931 s = "'~#\200\1'"; /* surely one char is unused...*/
1932 while (s[1] && strchr(PL_splitstr, *s)) s++;
1934 sv_catpvf(PL_linestr, "@F=split(%s%c",
1935 "q" + (delim == '\''), delim);
1936 for (s = PL_splitstr; *s; s++) {
1938 sv_catpvn(PL_linestr, "\\", 1);
1939 sv_catpvn(PL_linestr, s, 1);
1941 sv_catpvf(PL_linestr, "%c);", delim);
1945 sv_catpv(PL_linestr,"@F=split(' ');");
1948 sv_catpv(PL_linestr, "\n");
1949 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1950 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1951 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1952 SV *sv = NEWSV(85,0);
1954 sv_upgrade(sv, SVt_PVMG);
1955 sv_setsv(sv,PL_linestr);
1956 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1961 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1964 if (PL_preprocess && !PL_in_eval)
1965 (void)PerlProc_pclose(PL_rsfp);
1966 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1967 PerlIO_clearerr(PL_rsfp);
1969 (void)PerlIO_close(PL_rsfp);
1971 PL_doextract = FALSE;
1973 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1974 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1975 sv_catpv(PL_linestr,";}");
1976 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1977 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1978 PL_minus_n = PL_minus_p = 0;
1981 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1982 sv_setpv(PL_linestr,"");
1983 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1986 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1987 PL_doextract = FALSE;
1989 /* Incest with pod. */
1990 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1991 sv_setpv(PL_linestr, "");
1992 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1993 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1994 PL_doextract = FALSE;
1998 } while (PL_doextract);
1999 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2000 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2001 SV *sv = NEWSV(85,0);
2003 sv_upgrade(sv, SVt_PVMG);
2004 sv_setsv(sv,PL_linestr);
2005 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2007 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2008 if (PL_curcop->cop_line == 1) {
2009 while (s < PL_bufend && isSPACE(*s))
2011 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2015 if (*s == '#' && *(s+1) == '!')
2017 #ifdef ALTERNATE_SHEBANG
2019 static char as[] = ALTERNATE_SHEBANG;
2020 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2021 d = s + (sizeof(as) - 1);
2023 #endif /* ALTERNATE_SHEBANG */
2032 while (*d && !isSPACE(*d))
2036 #ifdef ARG_ZERO_IS_SCRIPT
2037 if (ipathend > ipath) {
2039 * HP-UX (at least) sets argv[0] to the script name,
2040 * which makes $^X incorrect. And Digital UNIX and Linux,
2041 * at least, set argv[0] to the basename of the Perl
2042 * interpreter. So, having found "#!", we'll set it right.
2044 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2045 assert(SvPOK(x) || SvGMAGICAL(x));
2046 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2047 sv_setpvn(x, ipath, ipathend - ipath);
2050 TAINT_NOT; /* $^X is always tainted, but that's OK */
2052 #endif /* ARG_ZERO_IS_SCRIPT */
2057 d = instr(s,"perl -");
2059 d = instr(s,"perl");
2060 #ifdef ALTERNATE_SHEBANG
2062 * If the ALTERNATE_SHEBANG on this system starts with a
2063 * character that can be part of a Perl expression, then if
2064 * we see it but not "perl", we're probably looking at the
2065 * start of Perl code, not a request to hand off to some
2066 * other interpreter. Similarly, if "perl" is there, but
2067 * not in the first 'word' of the line, we assume the line
2068 * contains the start of the Perl program.
2070 if (d && *s != '#') {
2072 while (*c && !strchr("; \t\r\n\f\v#", *c))
2075 d = Nullch; /* "perl" not in first word; ignore */
2077 *s = '#'; /* Don't try to parse shebang line */
2079 #endif /* ALTERNATE_SHEBANG */
2084 !instr(s,"indir") &&
2085 instr(PL_origargv[0],"perl"))
2091 while (s < PL_bufend && isSPACE(*s))
2093 if (s < PL_bufend) {
2094 Newz(899,newargv,PL_origargc+3,char*);
2096 while (s < PL_bufend && !isSPACE(*s))
2099 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2102 newargv = PL_origargv;
2104 PerlProc_execv(ipath, newargv);
2105 croak("Can't exec %s", ipath);
2108 U32 oldpdb = PL_perldb;
2109 bool oldn = PL_minus_n;
2110 bool oldp = PL_minus_p;
2112 while (*d && !isSPACE(*d)) d++;
2113 while (*d == ' ' || *d == '\t') d++;
2117 if (*d == 'M' || *d == 'm') {
2119 while (*d && !isSPACE(*d)) d++;
2120 croak("Too late for \"-%.*s\" option",
2123 d = moreswitches(d);
2125 if (PERLDB_LINE && !oldpdb ||
2126 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2127 /* if we have already added "LINE: while (<>) {",
2128 we must not do it again */
2130 sv_setpv(PL_linestr, "");
2131 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2132 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2133 PL_preambled = FALSE;
2135 (void)gv_fetchfile(PL_origfilename);
2142 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2144 PL_lex_state = LEX_FORMLINE;
2145 return yylex(PERL_YYLEX_PARAM);
2149 #ifdef PERL_STRICT_CR
2150 warn("Illegal character \\%03o (carriage return)", '\r');
2152 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2154 case ' ': case '\t': case '\f': case 013:
2159 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2161 while (s < d && *s != '\n')
2166 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2168 PL_lex_state = LEX_FORMLINE;
2169 return yylex(PERL_YYLEX_PARAM);
2178 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2183 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2186 if (strnEQ(s,"=>",2)) {
2187 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2188 OPERATOR('-'); /* unary minus */
2190 PL_last_uni = PL_oldbufptr;
2191 PL_last_lop_op = OP_FTEREAD; /* good enough */
2193 case 'r': FTST(OP_FTEREAD);
2194 case 'w': FTST(OP_FTEWRITE);
2195 case 'x': FTST(OP_FTEEXEC);
2196 case 'o': FTST(OP_FTEOWNED);
2197 case 'R': FTST(OP_FTRREAD);
2198 case 'W': FTST(OP_FTRWRITE);
2199 case 'X': FTST(OP_FTREXEC);
2200 case 'O': FTST(OP_FTROWNED);
2201 case 'e': FTST(OP_FTIS);
2202 case 'z': FTST(OP_FTZERO);
2203 case 's': FTST(OP_FTSIZE);
2204 case 'f': FTST(OP_FTFILE);
2205 case 'd': FTST(OP_FTDIR);
2206 case 'l': FTST(OP_FTLINK);
2207 case 'p': FTST(OP_FTPIPE);
2208 case 'S': FTST(OP_FTSOCK);
2209 case 'u': FTST(OP_FTSUID);
2210 case 'g': FTST(OP_FTSGID);
2211 case 'k': FTST(OP_FTSVTX);
2212 case 'b': FTST(OP_FTBLK);
2213 case 'c': FTST(OP_FTCHR);
2214 case 't': FTST(OP_FTTTY);
2215 case 'T': FTST(OP_FTTEXT);
2216 case 'B': FTST(OP_FTBINARY);
2217 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2218 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2219 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2221 croak("Unrecognized file test: -%c", (int)tmp);
2228 if (PL_expect == XOPERATOR)
2233 else if (*s == '>') {
2236 if (isIDFIRST_lazy(s)) {
2237 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2245 if (PL_expect == XOPERATOR)
2248 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2250 OPERATOR('-'); /* unary minus */
2257 if (PL_expect == XOPERATOR)
2262 if (PL_expect == XOPERATOR)
2265 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2271 if (PL_expect != XOPERATOR) {
2272 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2273 PL_expect = XOPERATOR;
2274 force_ident(PL_tokenbuf, '*');
2287 if (PL_expect == XOPERATOR) {
2291 PL_tokenbuf[0] = '%';
2292 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2293 if (!PL_tokenbuf[1]) {
2295 yyerror("Final % should be \\% or %name");
2298 PL_pending_ident = '%';
2320 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2321 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2326 if (PL_curcop->cop_line < PL_copline)
2327 PL_copline = PL_curcop->cop_line;
2338 if (PL_lex_brackets <= 0)
2339 yyerror("Unmatched right square bracket");
2342 if (PL_lex_state == LEX_INTERPNORMAL) {
2343 if (PL_lex_brackets == 0) {
2344 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2345 PL_lex_state = LEX_INTERPEND;
2352 if (PL_lex_brackets > 100) {
2353 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2354 if (newlb != PL_lex_brackstack) {
2356 PL_lex_brackstack = newlb;
2359 switch (PL_expect) {
2361 if (PL_lex_formbrack) {
2365 if (PL_oldoldbufptr == PL_last_lop)
2366 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2368 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2369 OPERATOR(HASHBRACK);
2371 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2374 PL_tokenbuf[0] = '\0';
2375 if (d < PL_bufend && *d == '-') {
2376 PL_tokenbuf[0] = '-';
2378 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2381 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2382 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2384 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2387 char minus = (PL_tokenbuf[0] == '-');
2388 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2395 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2399 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2404 if (PL_oldoldbufptr == PL_last_lop)
2405 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2407 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2410 OPERATOR(HASHBRACK);
2411 /* This hack serves to disambiguate a pair of curlies
2412 * as being a block or an anon hash. Normally, expectation
2413 * determines that, but in cases where we're not in a
2414 * position to expect anything in particular (like inside
2415 * eval"") we have to resolve the ambiguity. This code
2416 * covers the case where the first term in the curlies is a
2417 * quoted string. Most other cases need to be explicitly
2418 * disambiguated by prepending a `+' before the opening
2419 * curly in order to force resolution as an anon hash.
2421 * XXX should probably propagate the outer expectation
2422 * into eval"" to rely less on this hack, but that could
2423 * potentially break current behavior of eval"".
2427 if (*s == '\'' || *s == '"' || *s == '`') {
2428 /* common case: get past first string, handling escapes */
2429 for (t++; t < PL_bufend && *t != *s;)
2430 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2434 else if (*s == 'q') {
2437 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2438 && !isALNUM(*t)))) {
2440 char open, close, term;
2443 while (t < PL_bufend && isSPACE(*t))
2447 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2451 for (t++; t < PL_bufend; t++) {
2452 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2454 else if (*t == open)
2458 for (t++; t < PL_bufend; t++) {
2459 if (*t == '\\' && t+1 < PL_bufend)
2461 else if (*t == close && --brackets <= 0)
2463 else if (*t == open)
2469 else if (isIDFIRST_lazy(s)) {
2470 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2472 while (t < PL_bufend && isSPACE(*t))
2474 /* if comma follows first term, call it an anon hash */
2475 /* XXX it could be a comma expression with loop modifiers */
2476 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2477 || (*t == '=' && t[1] == '>')))
2478 OPERATOR(HASHBRACK);
2479 if (PL_expect == XREF)
2480 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2482 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2488 yylval.ival = PL_curcop->cop_line;
2489 if (isSPACE(*s) || *s == '#')
2490 PL_copline = NOLINE; /* invalidate current command line number */
2495 if (PL_lex_brackets <= 0)
2496 yyerror("Unmatched right curly bracket");
2498 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2499 if (PL_lex_brackets < PL_lex_formbrack)
2500 PL_lex_formbrack = 0;
2501 if (PL_lex_state == LEX_INTERPNORMAL) {
2502 if (PL_lex_brackets == 0) {
2503 if (PL_lex_fakebrack) {
2504 PL_lex_state = LEX_INTERPEND;
2506 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2508 if (*s == '-' && s[1] == '>')
2509 PL_lex_state = LEX_INTERPENDMAYBE;
2510 else if (*s != '[' && *s != '{')
2511 PL_lex_state = LEX_INTERPEND;
2514 if (PL_lex_brackets < PL_lex_fakebrack) {
2516 PL_lex_fakebrack = 0;
2517 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2527 if (PL_expect == XOPERATOR) {
2528 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2529 PL_curcop->cop_line--;
2530 warner(WARN_SEMICOLON, PL_warn_nosemi);
2531 PL_curcop->cop_line++;
2536 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2538 PL_expect = XOPERATOR;
2539 force_ident(PL_tokenbuf, '&');
2543 yylval.ival = (OPpENTERSUB_AMPER<<8);
2562 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2563 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2565 if (PL_expect == XSTATE && isALPHA(tmp) &&
2566 (s == PL_linestart+1 || s[-2] == '\n') )
2568 if (PL_in_eval && !PL_rsfp) {
2573 if (strnEQ(s,"=cut",4)) {
2587 PL_doextract = TRUE;
2590 if (PL_lex_brackets < PL_lex_formbrack) {
2592 #ifdef PERL_STRICT_CR
2593 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2595 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2597 if (*t == '\n' || *t == '#') {
2615 if (PL_expect != XOPERATOR) {
2616 if (s[1] != '<' && !strchr(s,'>'))
2619 s = scan_heredoc(s);
2621 s = scan_inputsymbol(s);
2622 TERM(sublex_start());
2627 SHop(OP_LEFT_SHIFT);
2641 SHop(OP_RIGHT_SHIFT);
2650 if (PL_expect == XOPERATOR) {
2651 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2654 return ','; /* grandfather non-comma-format format */
2658 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2659 if (PL_expect == XOPERATOR)
2660 no_op("Array length", PL_bufptr);
2661 PL_tokenbuf[0] = '@';
2662 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2664 if (!PL_tokenbuf[1])
2666 PL_expect = XOPERATOR;
2667 PL_pending_ident = '#';
2671 if (PL_expect == XOPERATOR)
2672 no_op("Scalar", PL_bufptr);
2673 PL_tokenbuf[0] = '$';
2674 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2675 if (!PL_tokenbuf[1]) {
2677 yyerror("Final $ should be \\$ or $name");
2681 /* This kludge not intended to be bulletproof. */
2682 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2683 yylval.opval = newSVOP(OP_CONST, 0,
2684 newSViv((IV)PL_compiling.cop_arybase));
2685 yylval.opval->op_private = OPpCONST_ARYBASE;
2691 if (PL_lex_state == LEX_NORMAL)
2694 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2697 PL_tokenbuf[0] = '@';
2698 if (ckWARN(WARN_SYNTAX)) {
2700 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2703 PL_bufptr = skipspace(PL_bufptr);
2704 while (t < PL_bufend && *t != ']')
2707 "Multidimensional syntax %.*s not supported",
2708 (t - PL_bufptr) + 1, PL_bufptr);
2712 else if (*s == '{') {
2713 PL_tokenbuf[0] = '%';
2714 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2715 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2717 char tmpbuf[sizeof PL_tokenbuf];
2719 for (t++; isSPACE(*t); t++) ;
2720 if (isIDFIRST_lazy(t)) {
2721 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2722 for (; isSPACE(*t); t++) ;
2723 if (*t == ';' && get_cv(tmpbuf, FALSE))
2725 "You need to quote \"%s\"", tmpbuf);
2731 PL_expect = XOPERATOR;
2732 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
2733 bool islop = (PL_last_lop == PL_oldoldbufptr);
2734 if (!islop || PL_last_lop_op == OP_GREPSTART)
2735 PL_expect = XOPERATOR;
2736 else if (strchr("$@\"'`q", *s))
2737 PL_expect = XTERM; /* e.g. print $fh "foo" */
2738 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2739 PL_expect = XTERM; /* e.g. print $fh &sub */
2740 else if (isIDFIRST_lazy(s)) {
2741 char tmpbuf[sizeof PL_tokenbuf];
2742 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2743 if (tmp = keyword(tmpbuf, len)) {
2744 /* binary operators exclude handle interpretations */
2756 PL_expect = XTERM; /* e.g. print $fh length() */
2761 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2762 if (gv && GvCVu(gv))
2763 PL_expect = XTERM; /* e.g. print $fh subr() */
2766 else if (isDIGIT(*s))
2767 PL_expect = XTERM; /* e.g. print $fh 3 */
2768 else if (*s == '.' && isDIGIT(s[1]))
2769 PL_expect = XTERM; /* e.g. print $fh .3 */
2770 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2771 PL_expect = XTERM; /* e.g. print $fh -1 */
2772 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2773 PL_expect = XTERM; /* print $fh <<"EOF" */
2775 PL_pending_ident = '$';
2779 if (PL_expect == XOPERATOR)
2781 PL_tokenbuf[0] = '@';
2782 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2783 if (!PL_tokenbuf[1]) {
2785 yyerror("Final @ should be \\@ or @name");
2788 if (PL_lex_state == LEX_NORMAL)
2790 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2792 PL_tokenbuf[0] = '%';
2794 /* Warn about @ where they meant $. */
2795 if (ckWARN(WARN_SYNTAX)) {
2796 if (*s == '[' || *s == '{') {
2798 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2800 if (*t == '}' || *t == ']') {
2802 PL_bufptr = skipspace(PL_bufptr);
2804 "Scalar value %.*s better written as $%.*s",
2805 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2810 PL_pending_ident = '@';
2813 case '/': /* may either be division or pattern */
2814 case '?': /* may either be conditional or pattern */
2815 if (PL_expect != XOPERATOR) {
2816 /* Disable warning on "study /blah/" */
2817 if (PL_oldoldbufptr == PL_last_uni
2818 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2819 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2821 s = scan_pat(s,OP_MATCH);
2822 TERM(sublex_start());
2830 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2831 #ifdef PERL_STRICT_CR
2834 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2836 && (s == PL_linestart || s[-1] == '\n') )
2838 PL_lex_formbrack = 0;
2842 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2848 yylval.ival = OPf_SPECIAL;
2854 if (PL_expect != XOPERATOR)
2859 case '0': case '1': case '2': case '3': case '4':
2860 case '5': case '6': case '7': case '8': case '9':
2862 if (PL_expect == XOPERATOR)
2868 if (PL_expect == XOPERATOR) {
2869 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2872 return ','; /* grandfather non-comma-format format */
2878 missingterm((char*)0);
2879 yylval.ival = OP_CONST;
2880 TERM(sublex_start());
2884 if (PL_expect == XOPERATOR) {
2885 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2888 return ','; /* grandfather non-comma-format format */
2894 missingterm((char*)0);
2895 yylval.ival = OP_CONST;
2896 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2897 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2898 yylval.ival = OP_STRINGIFY;
2902 TERM(sublex_start());
2906 if (PL_expect == XOPERATOR)
2907 no_op("Backticks",s);
2909 missingterm((char*)0);
2910 yylval.ival = OP_BACKTICK;
2912 TERM(sublex_start());
2916 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2917 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2919 if (PL_expect == XOPERATOR)
2920 no_op("Backslash",s);
2924 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2964 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2966 /* Some keywords can be followed by any delimiter, including ':' */
2967 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2968 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2969 (PL_tokenbuf[0] == 'q' &&
2970 strchr("qwxr", PL_tokenbuf[1]))));
2972 /* x::* is just a word, unless x is "CORE" */
2973 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2977 while (d < PL_bufend && isSPACE(*d))
2978 d++; /* no comments skipped here, or s### is misparsed */
2980 /* Is this a label? */
2981 if (!tmp && PL_expect == XSTATE
2982 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2984 yylval.pval = savepv(PL_tokenbuf);
2989 /* Check for keywords */
2990 tmp = keyword(PL_tokenbuf, len);
2992 /* Is this a word before a => operator? */
2993 if (strnEQ(d,"=>",2)) {
2995 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2996 yylval.opval->op_private = OPpCONST_BARE;
3000 if (tmp < 0) { /* second-class keyword? */
3001 GV *ogv = Nullgv; /* override (winner) */
3002 GV *hgv = Nullgv; /* hidden (loser) */
3003 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3005 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3008 if (GvIMPORTED_CV(gv))
3010 else if (! CvMETHOD(cv))
3014 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3015 (gv = *gvp) != (GV*)&PL_sv_undef &&
3016 GvCVu(gv) && GvIMPORTED_CV(gv))
3022 tmp = 0; /* overridden by import or by GLOBAL */
3025 && -tmp==KEY_lock /* XXX generalizable kludge */
3026 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3028 tmp = 0; /* any sub overrides "weak" keyword */
3030 else { /* no override */
3034 if (ckWARN(WARN_AMBIGUOUS) && hgv
3035 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3036 warner(WARN_AMBIGUOUS,
3037 "Ambiguous call resolved as CORE::%s(), %s",
3038 GvENAME(hgv), "qualify as such or use &");
3045 default: /* not a keyword */
3048 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3050 /* Get the rest if it looks like a package qualifier */
3052 if (*s == '\'' || *s == ':' && s[1] == ':') {
3054 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3057 croak("Bad name after %s%s", PL_tokenbuf,
3058 *s == '\'' ? "'" : "::");
3062 if (PL_expect == XOPERATOR) {
3063 if (PL_bufptr == PL_linestart) {
3064 PL_curcop->cop_line--;
3065 warner(WARN_SEMICOLON, PL_warn_nosemi);
3066 PL_curcop->cop_line++;
3069 no_op("Bareword",s);
3072 /* Look for a subroutine with this name in current package,
3073 unless name is "Foo::", in which case Foo is a bearword
3074 (and a package name). */
3077 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3079 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3081 "Bareword \"%s\" refers to nonexistent package",
3084 PL_tokenbuf[len] = '\0';
3091 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3094 /* if we saw a global override before, get the right name */
3097 sv = newSVpvn("CORE::GLOBAL::",14);
3098 sv_catpv(sv,PL_tokenbuf);
3101 sv = newSVpv(PL_tokenbuf,0);
3103 /* Presume this is going to be a bareword of some sort. */
3106 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3107 yylval.opval->op_private = OPpCONST_BARE;
3109 /* And if "Foo::", then that's what it certainly is. */
3114 /* See if it's the indirect object for a list operator. */
3116 if (PL_oldoldbufptr &&
3117 PL_oldoldbufptr < PL_bufptr &&
3118 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3119 /* NO SKIPSPACE BEFORE HERE! */
3120 (PL_expect == XREF ||
3121 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3123 bool immediate_paren = *s == '(';
3125 /* (Now we can afford to cross potential line boundary.) */
3128 /* Two barewords in a row may indicate method call. */
3130 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3133 /* If not a declared subroutine, it's an indirect object. */
3134 /* (But it's an indir obj regardless for sort.) */
3136 if ((PL_last_lop_op == OP_SORT ||
3137 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3138 (PL_last_lop_op != OP_MAPSTART &&
3139 PL_last_lop_op != OP_GREPSTART))
3141 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3146 /* If followed by a paren, it's certainly a subroutine. */
3148 PL_expect = XOPERATOR;
3152 if (gv && GvCVu(gv)) {
3153 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3154 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3159 PL_nextval[PL_nexttoke].opval = yylval.opval;
3160 PL_expect = XOPERATOR;
3166 /* If followed by var or block, call it a method (unless sub) */
3168 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3169 PL_last_lop = PL_oldbufptr;
3170 PL_last_lop_op = OP_METHOD;
3174 /* If followed by a bareword, see if it looks like indir obj. */
3176 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3179 /* Not a method, so call it a subroutine (if defined) */
3181 if (gv && GvCVu(gv)) {
3183 if (lastchar == '-')
3184 warn("Ambiguous use of -%s resolved as -&%s()",
3185 PL_tokenbuf, PL_tokenbuf);
3186 /* Check for a constant sub */
3188 if ((sv = cv_const_sv(cv))) {
3190 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3191 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3192 yylval.opval->op_private = 0;
3196 /* Resolve to GV now. */
3197 op_free(yylval.opval);
3198 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3199 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3200 PL_last_lop = PL_oldbufptr;
3201 PL_last_lop_op = OP_ENTERSUB;
3202 /* Is there a prototype? */
3205 char *proto = SvPV((SV*)cv, len);
3208 if (strEQ(proto, "$"))
3210 if (*proto == '&' && *s == '{') {
3211 sv_setpv(PL_subname,"__ANON__");
3215 PL_nextval[PL_nexttoke].opval = yylval.opval;
3221 /* Call it a bare word */
3223 if (PL_hints & HINT_STRICT_SUBS)
3224 yylval.opval->op_private |= OPpCONST_STRICT;
3227 if (ckWARN(WARN_RESERVED)) {
3228 if (lastchar != '-') {
3229 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3231 warner(WARN_RESERVED, PL_warn_reserved,
3238 if (lastchar && strchr("*%&", lastchar)) {
3239 warn("Operator or semicolon missing before %c%s",
3240 lastchar, PL_tokenbuf);
3241 warn("Ambiguous use of %c resolved as operator %c",
3242 lastchar, lastchar);
3248 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3249 newSVsv(GvSV(PL_curcop->cop_filegv)));
3253 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3254 newSVpvf("%ld", (long)PL_curcop->cop_line));
3257 case KEY___PACKAGE__:
3258 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3260 ? newSVsv(PL_curstname)
3269 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3270 char *pname = "main";
3271 if (PL_tokenbuf[2] == 'D')
3272 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3273 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3276 GvIOp(gv) = newIO();
3277 IoIFP(GvIOp(gv)) = PL_rsfp;
3278 #if defined(HAS_FCNTL) && defined(F_SETFD)
3280 int fd = PerlIO_fileno(PL_rsfp);
3281 fcntl(fd,F_SETFD,fd >= 3);
3284 /* Mark this internal pseudo-handle as clean */
3285 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3287 IoTYPE(GvIOp(gv)) = '|';
3288 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3289 IoTYPE(GvIOp(gv)) = '-';
3291 IoTYPE(GvIOp(gv)) = '<';
3302 if (PL_expect == XSTATE) {
3309 if (*s == ':' && s[1] == ':') {
3312 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3313 tmp = keyword(PL_tokenbuf, len);
3327 LOP(OP_ACCEPT,XTERM);
3333 LOP(OP_ATAN2,XTERM);
3342 LOP(OP_BLESS,XTERM);
3351 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3368 if (!PL_cryptseen++)
3371 LOP(OP_CRYPT,XTERM);
3374 if (ckWARN(WARN_OCTAL)) {
3375 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3376 if (*d != '0' && isDIGIT(*d))
3377 yywarn("chmod: mode argument is missing initial 0");
3379 LOP(OP_CHMOD,XTERM);
3382 LOP(OP_CHOWN,XTERM);
3385 LOP(OP_CONNECT,XTERM);
3401 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3405 PL_hints |= HINT_BLOCK_SCOPE;
3415 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3416 LOP(OP_DBMOPEN,XTERM);
3422 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3429 yylval.ival = PL_curcop->cop_line;
3443 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3444 UNIBRACK(OP_ENTEREVAL);
3459 case KEY_endhostent:
3465 case KEY_endservent:
3468 case KEY_endprotoent:
3479 yylval.ival = PL_curcop->cop_line;
3481 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3483 if ((PL_bufend - p) >= 3 &&
3484 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3487 if (isIDFIRST_lazy(p))
3488 croak("Missing $ on loop variable");
3493 LOP(OP_FORMLINE,XTERM);
3499 LOP(OP_FCNTL,XTERM);
3505 LOP(OP_FLOCK,XTERM);
3514 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3517 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3532 case KEY_getpriority:
3533 LOP(OP_GETPRIORITY,XTERM);
3535 case KEY_getprotobyname:
3538 case KEY_getprotobynumber:
3539 LOP(OP_GPBYNUMBER,XTERM);
3541 case KEY_getprotoent:
3553 case KEY_getpeername:
3554 UNI(OP_GETPEERNAME);
3556 case KEY_gethostbyname:
3559 case KEY_gethostbyaddr:
3560 LOP(OP_GHBYADDR,XTERM);
3562 case KEY_gethostent:
3565 case KEY_getnetbyname:
3568 case KEY_getnetbyaddr:
3569 LOP(OP_GNBYADDR,XTERM);
3574 case KEY_getservbyname:
3575 LOP(OP_GSBYNAME,XTERM);
3577 case KEY_getservbyport:
3578 LOP(OP_GSBYPORT,XTERM);
3580 case KEY_getservent:
3583 case KEY_getsockname:
3584 UNI(OP_GETSOCKNAME);
3586 case KEY_getsockopt:
3587 LOP(OP_GSOCKOPT,XTERM);
3609 yylval.ival = PL_curcop->cop_line;
3613 LOP(OP_INDEX,XTERM);
3619 LOP(OP_IOCTL,XTERM);
3631 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3662 LOP(OP_LISTEN,XTERM);
3671 s = scan_pat(s,OP_MATCH);
3672 TERM(sublex_start());
3675 LOP(OP_MAPSTART, XREF);
3678 LOP(OP_MKDIR,XTERM);
3681 LOP(OP_MSGCTL,XTERM);
3684 LOP(OP_MSGGET,XTERM);
3687 LOP(OP_MSGRCV,XTERM);
3690 LOP(OP_MSGSND,XTERM);
3695 if (isIDFIRST_lazy(s)) {
3696 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3697 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3698 if (!PL_in_my_stash) {
3701 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3708 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3715 if (PL_expect != XSTATE)
3716 yyerror("\"no\" not allowed in expression");
3717 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3718 s = force_version(s);
3727 if (isIDFIRST_lazy(s)) {
3729 for (d = s; isALNUM_lazy(d); d++) ;
3731 if (strchr("|&*+-=!?:.", *t))
3732 warn("Precedence problem: open %.*s should be open(%.*s)",
3738 yylval.ival = OP_OR;
3748 LOP(OP_OPEN_DIR,XTERM);
3751 checkcomma(s,PL_tokenbuf,"filehandle");
3755 checkcomma(s,PL_tokenbuf,"filehandle");
3774 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3778 LOP(OP_PIPE_OP,XTERM);
3783 missingterm((char*)0);
3784 yylval.ival = OP_CONST;
3785 TERM(sublex_start());
3793 missingterm((char*)0);
3795 if (SvCUR(PL_lex_stuff)) {
3798 d = SvPV_force(PL_lex_stuff, len);
3800 for (; isSPACE(*d) && len; --len, ++d) ;
3803 if (!warned && ckWARN(WARN_SYNTAX)) {
3804 for (; !isSPACE(*d) && len; --len, ++d) {
3807 "Possible attempt to separate words with commas");
3810 else if (*d == '#') {
3812 "Possible attempt to put comments in qw() list");
3818 for (; !isSPACE(*d) && len; --len, ++d) ;
3820 words = append_elem(OP_LIST, words,
3821 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
3825 PL_nextval[PL_nexttoke].opval = words;
3830 SvREFCNT_dec(PL_lex_stuff);
3831 PL_lex_stuff = Nullsv;
3838 missingterm((char*)0);
3839 yylval.ival = OP_STRINGIFY;
3840 if (SvIVX(PL_lex_stuff) == '\'')
3841 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3842 TERM(sublex_start());
3845 s = scan_pat(s,OP_QR);
3846 TERM(sublex_start());
3851 missingterm((char*)0);
3852 yylval.ival = OP_BACKTICK;
3854 TERM(sublex_start());
3860 *PL_tokenbuf = '\0';
3861 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3862 if (isIDFIRST_lazy(PL_tokenbuf))
3863 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3865 yyerror("<> should be quotes");
3872 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3876 LOP(OP_RENAME,XTERM);
3885 LOP(OP_RINDEX,XTERM);
3908 LOP(OP_REVERSE,XTERM);
3919 TERM(sublex_start());
3921 TOKEN(1); /* force error */
3930 LOP(OP_SELECT,XTERM);
3936 LOP(OP_SEMCTL,XTERM);
3939 LOP(OP_SEMGET,XTERM);
3942 LOP(OP_SEMOP,XTERM);
3948 LOP(OP_SETPGRP,XTERM);
3950 case KEY_setpriority:
3951 LOP(OP_SETPRIORITY,XTERM);
3953 case KEY_sethostent:
3959 case KEY_setservent:
3962 case KEY_setprotoent:
3972 LOP(OP_SEEKDIR,XTERM);
3974 case KEY_setsockopt:
3975 LOP(OP_SSOCKOPT,XTERM);
3981 LOP(OP_SHMCTL,XTERM);
3984 LOP(OP_SHMGET,XTERM);
3987 LOP(OP_SHMREAD,XTERM);
3990 LOP(OP_SHMWRITE,XTERM);
3993 LOP(OP_SHUTDOWN,XTERM);
4002 LOP(OP_SOCKET,XTERM);
4004 case KEY_socketpair:
4005 LOP(OP_SOCKPAIR,XTERM);
4008 checkcomma(s,PL_tokenbuf,"subroutine name");
4010 if (*s == ';' || *s == ')') /* probably a close */
4011 croak("sort is now a reserved word");
4013 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4017 LOP(OP_SPLIT,XTERM);
4020 LOP(OP_SPRINTF,XTERM);
4023 LOP(OP_SPLICE,XTERM);
4039 LOP(OP_SUBSTR,XTERM);
4046 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4047 char tmpbuf[sizeof PL_tokenbuf];
4049 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4050 if (strchr(tmpbuf, ':'))
4051 sv_setpv(PL_subname, tmpbuf);
4053 sv_setsv(PL_subname,PL_curstname);
4054 sv_catpvn(PL_subname,"::",2);
4055 sv_catpvn(PL_subname,tmpbuf,len);
4057 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4061 PL_expect = XTERMBLOCK;
4062 sv_setpv(PL_subname,"?");
4065 if (tmp == KEY_format) {
4068 PL_lex_formbrack = PL_lex_brackets + 1;
4072 /* Look for a prototype */
4079 SvREFCNT_dec(PL_lex_stuff);
4080 PL_lex_stuff = Nullsv;
4081 croak("Prototype not terminated");
4084 d = SvPVX(PL_lex_stuff);
4086 for (p = d; *p; ++p) {
4091 SvCUR(PL_lex_stuff) = tmp;
4094 PL_nextval[1] = PL_nextval[0];
4095 PL_nexttype[1] = PL_nexttype[0];
4096 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4097 PL_nexttype[0] = THING;
4098 if (PL_nexttoke == 1) {
4099 PL_lex_defer = PL_lex_state;
4100 PL_lex_expect = PL_expect;
4101 PL_lex_state = LEX_KNOWNEXT;
4103 PL_lex_stuff = Nullsv;
4106 if (*SvPV(PL_subname,n_a) == '?') {
4107 sv_setpv(PL_subname,"__ANON__");
4114 LOP(OP_SYSTEM,XREF);
4117 LOP(OP_SYMLINK,XTERM);
4120 LOP(OP_SYSCALL,XTERM);
4123 LOP(OP_SYSOPEN,XTERM);
4126 LOP(OP_SYSSEEK,XTERM);
4129 LOP(OP_SYSREAD,XTERM);
4132 LOP(OP_SYSWRITE,XTERM);
4136 TERM(sublex_start());
4157 LOP(OP_TRUNCATE,XTERM);
4169 yylval.ival = PL_curcop->cop_line;
4173 yylval.ival = PL_curcop->cop_line;
4177 LOP(OP_UNLINK,XTERM);
4183 LOP(OP_UNPACK,XTERM);
4186 LOP(OP_UTIME,XTERM);
4189 if (ckWARN(WARN_OCTAL)) {
4190 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4191 if (*d != '0' && isDIGIT(*d))
4192 yywarn("umask: argument is missing initial 0");
4197 LOP(OP_UNSHIFT,XTERM);
4200 if (PL_expect != XSTATE)
4201 yyerror("\"use\" not allowed in expression");
4204 s = force_version(s);
4205 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4206 PL_nextval[PL_nexttoke].opval = Nullop;
4211 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4212 s = force_version(s);
4225 yylval.ival = PL_curcop->cop_line;
4229 PL_hints |= HINT_BLOCK_SCOPE;
4236 LOP(OP_WAITPID,XTERM);
4244 static char ctl_l[2];
4246 if (ctl_l[0] == '\0')
4247 ctl_l[0] = toCTRL('L');
4248 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4251 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4256 if (PL_expect == XOPERATOR)
4262 yylval.ival = OP_XOR;
4267 TERM(sublex_start());
4273 Perl_keyword(pTHX_ register char *d, I32 len)
4278 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4279 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4280 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4281 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4282 if (strEQ(d,"__END__")) return KEY___END__;
4286 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4291 if (strEQ(d,"and")) return -KEY_and;
4292 if (strEQ(d,"abs")) return -KEY_abs;
4295 if (strEQ(d,"alarm")) return -KEY_alarm;
4296 if (strEQ(d,"atan2")) return -KEY_atan2;
4299 if (strEQ(d,"accept")) return -KEY_accept;
4304 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4307 if (strEQ(d,"bless")) return -KEY_bless;
4308 if (strEQ(d,"bind")) return -KEY_bind;
4309 if (strEQ(d,"binmode")) return -KEY_binmode;
4312 if (strEQ(d,"CORE")) return -KEY_CORE;
4317 if (strEQ(d,"cmp")) return -KEY_cmp;
4318 if (strEQ(d,"chr")) return -KEY_chr;
4319 if (strEQ(d,"cos")) return -KEY_cos;
4322 if (strEQ(d,"chop")) return KEY_chop;
4325 if (strEQ(d,"close")) return -KEY_close;
4326 if (strEQ(d,"chdir")) return -KEY_chdir;
4327 if (strEQ(d,"chomp")) return KEY_chomp;
4328 if (strEQ(d,"chmod")) return -KEY_chmod;
4329 if (strEQ(d,"chown")) return -KEY_chown;
4330 if (strEQ(d,"crypt")) return -KEY_crypt;
4333 if (strEQ(d,"chroot")) return -KEY_chroot;
4334 if (strEQ(d,"caller")) return -KEY_caller;
4337 if (strEQ(d,"connect")) return -KEY_connect;
4340 if (strEQ(d,"closedir")) return -KEY_closedir;
4341 if (strEQ(d,"continue")) return -KEY_continue;
4346 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4351 if (strEQ(d,"do")) return KEY_do;
4354 if (strEQ(d,"die")) return -KEY_die;
4357 if (strEQ(d,"dump")) return -KEY_dump;
4360 if (strEQ(d,"delete")) return KEY_delete;
4363 if (strEQ(d,"defined")) return KEY_defined;
4364 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4367 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4372 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4373 if (strEQ(d,"END")) return KEY_END;
4378 if (strEQ(d,"eq")) return -KEY_eq;
4381 if (strEQ(d,"eof")) return -KEY_eof;
4382 if (strEQ(d,"exp")) return -KEY_exp;
4385 if (strEQ(d,"else")) return KEY_else;
4386 if (strEQ(d,"exit")) return -KEY_exit;
4387 if (strEQ(d,"eval")) return KEY_eval;
4388 if (strEQ(d,"exec")) return -KEY_exec;
4389 if (strEQ(d,"each")) return KEY_each;
4392 if (strEQ(d,"elsif")) return KEY_elsif;
4395 if (strEQ(d,"exists")) return KEY_exists;
4396 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4399 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4400 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4403 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4406 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4407 if (strEQ(d,"endservent")) return -KEY_endservent;
4410 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4417 if (strEQ(d,"for")) return KEY_for;
4420 if (strEQ(d,"fork")) return -KEY_fork;
4423 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4424 if (strEQ(d,"flock")) return -KEY_flock;
4427 if (strEQ(d,"format")) return KEY_format;
4428 if (strEQ(d,"fileno")) return -KEY_fileno;
4431 if (strEQ(d,"foreach")) return KEY_foreach;
4434 if (strEQ(d,"formline")) return -KEY_formline;
4440 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4441 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4445 if (strnEQ(d,"get",3)) {
4450 if (strEQ(d,"ppid")) return -KEY_getppid;
4451 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4454 if (strEQ(d,"pwent")) return -KEY_getpwent;
4455 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4456 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4459 if (strEQ(d,"peername")) return -KEY_getpeername;
4460 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4461 if (strEQ(d,"priority")) return -KEY_getpriority;
4464 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4467 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4471 else if (*d == 'h') {
4472 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4473 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4474 if (strEQ(d,"hostent")) return -KEY_gethostent;
4476 else if (*d == 'n') {
4477 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4478 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4479 if (strEQ(d,"netent")) return -KEY_getnetent;
4481 else if (*d == 's') {
4482 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4483 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4484 if (strEQ(d,"servent")) return -KEY_getservent;
4485 if (strEQ(d,"sockname")) return -KEY_getsockname;
4486 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4488 else if (*d == 'g') {
4489 if (strEQ(d,"grent")) return -KEY_getgrent;
4490 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4491 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4493 else if (*d == 'l') {
4494 if (strEQ(d,"login")) return -KEY_getlogin;
4496 else if (strEQ(d,"c")) return -KEY_getc;
4501 if (strEQ(d,"gt")) return -KEY_gt;
4502 if (strEQ(d,"ge")) return -KEY_ge;
4505 if (strEQ(d,"grep")) return KEY_grep;
4506 if (strEQ(d,"goto")) return KEY_goto;
4507 if (strEQ(d,"glob")) return KEY_glob;
4510 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4515 if (strEQ(d,"hex")) return -KEY_hex;
4518 if (strEQ(d,"INIT")) return KEY_INIT;
4523 if (strEQ(d,"if")) return KEY_if;
4526 if (strEQ(d,"int")) return -KEY_int;
4529 if (strEQ(d,"index")) return -KEY_index;
4530 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4535 if (strEQ(d,"join")) return -KEY_join;
4539 if (strEQ(d,"keys")) return KEY_keys;
4540 if (strEQ(d,"kill")) return -KEY_kill;
4545 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4546 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4552 if (strEQ(d,"lt")) return -KEY_lt;
4553 if (strEQ(d,"le")) return -KEY_le;
4554 if (strEQ(d,"lc")) return -KEY_lc;
4557 if (strEQ(d,"log")) return -KEY_log;
4560 if (strEQ(d,"last")) return KEY_last;
4561 if (strEQ(d,"link")) return -KEY_link;
4562 if (strEQ(d,"lock")) return -KEY_lock;
4565 if (strEQ(d,"local")) return KEY_local;
4566 if (strEQ(d,"lstat")) return -KEY_lstat;
4569 if (strEQ(d,"length")) return -KEY_length;
4570 if (strEQ(d,"listen")) return -KEY_listen;
4573 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4576 if (strEQ(d,"localtime")) return -KEY_localtime;
4582 case 1: return KEY_m;
4584 if (strEQ(d,"my")) return KEY_my;
4587 if (strEQ(d,"map")) return KEY_map;
4590 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4593 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4594 if (strEQ(d,"msgget")) return -KEY_msgget;
4595 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4596 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4601 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4604 if (strEQ(d,"next")) return KEY_next;
4605 if (strEQ(d,"ne")) return -KEY_ne;
4606 if (strEQ(d,"not")) return -KEY_not;
4607 if (strEQ(d,"no")) return KEY_no;
4612 if (strEQ(d,"or")) return -KEY_or;
4615 if (strEQ(d,"ord")) return -KEY_ord;
4616 if (strEQ(d,"oct")) return -KEY_oct;
4617 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4621 if (strEQ(d,"open")) return -KEY_open;
4624 if (strEQ(d,"opendir")) return -KEY_opendir;
4631 if (strEQ(d,"pop")) return KEY_pop;
4632 if (strEQ(d,"pos")) return KEY_pos;
4635 if (strEQ(d,"push")) return KEY_push;
4636 if (strEQ(d,"pack")) return -KEY_pack;
4637 if (strEQ(d,"pipe")) return -KEY_pipe;
4640 if (strEQ(d,"print")) return KEY_print;
4643 if (strEQ(d,"printf")) return KEY_printf;
4646 if (strEQ(d,"package")) return KEY_package;
4649 if (strEQ(d,"prototype")) return KEY_prototype;
4654 if (strEQ(d,"q")) return KEY_q;
4655 if (strEQ(d,"qr")) return KEY_qr;
4656 if (strEQ(d,"qq")) return KEY_qq;
4657 if (strEQ(d,"qw")) return KEY_qw;
4658 if (strEQ(d,"qx")) return KEY_qx;
4660 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4665 if (strEQ(d,"ref")) return -KEY_ref;
4668 if (strEQ(d,"read")) return -KEY_read;
4669 if (strEQ(d,"rand")) return -KEY_rand;
4670 if (strEQ(d,"recv")) return -KEY_recv;
4671 if (strEQ(d,"redo")) return KEY_redo;
4674 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4675 if (strEQ(d,"reset")) return -KEY_reset;
4678 if (strEQ(d,"return")) return KEY_return;
4679 if (strEQ(d,"rename")) return -KEY_rename;
4680 if (strEQ(d,"rindex")) return -KEY_rindex;
4683 if (strEQ(d,"require")) return -KEY_require;
4684 if (strEQ(d,"reverse")) return -KEY_reverse;
4685 if (strEQ(d,"readdir")) return -KEY_readdir;
4688 if (strEQ(d,"readlink")) return -KEY_readlink;
4689 if (strEQ(d,"readline")) return -KEY_readline;
4690 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4693 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4699 case 0: return KEY_s;
4701 if (strEQ(d,"scalar")) return KEY_scalar;
4706 if (strEQ(d,"seek")) return -KEY_seek;
4707 if (strEQ(d,"send")) return -KEY_send;
4710 if (strEQ(d,"semop")) return -KEY_semop;
4713 if (strEQ(d,"select")) return -KEY_select;
4714 if (strEQ(d,"semctl")) return -KEY_semctl;
4715 if (strEQ(d,"semget")) return -KEY_semget;
4718 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4719 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4722 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4723 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4726 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4729 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4730 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4731 if (strEQ(d,"setservent")) return -KEY_setservent;
4734 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4735 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4742 if (strEQ(d,"shift")) return KEY_shift;
4745 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4746 if (strEQ(d,"shmget")) return -KEY_shmget;
4749 if (strEQ(d,"shmread")) return -KEY_shmread;
4752 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4753 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4758 if (strEQ(d,"sin")) return -KEY_sin;
4761 if (strEQ(d,"sleep")) return -KEY_sleep;
4764 if (strEQ(d,"sort")) return KEY_sort;
4765 if (strEQ(d,"socket")) return -KEY_socket;
4766 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4769 if (strEQ(d,"split")) return KEY_split;
4770 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4771 if (strEQ(d,"splice")) return KEY_splice;
4774 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4777 if (strEQ(d,"srand")) return -KEY_srand;
4780 if (strEQ(d,"stat")) return -KEY_stat;
4781 if (strEQ(d,"study")) return KEY_study;
4784 if (strEQ(d,"substr")) return -KEY_substr;
4785 if (strEQ(d,"sub")) return KEY_sub;
4790 if (strEQ(d,"system")) return -KEY_system;
4793 if (strEQ(d,"symlink")) return -KEY_symlink;
4794 if (strEQ(d,"syscall")) return -KEY_syscall;
4795 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4796 if (strEQ(d,"sysread")) return -KEY_sysread;
4797 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4800 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4809 if (strEQ(d,"tr")) return KEY_tr;
4812 if (strEQ(d,"tie")) return KEY_tie;
4815 if (strEQ(d,"tell")) return -KEY_tell;
4816 if (strEQ(d,"tied")) return KEY_tied;
4817 if (strEQ(d,"time")) return -KEY_time;
4820 if (strEQ(d,"times")) return -KEY_times;
4823 if (strEQ(d,"telldir")) return -KEY_telldir;
4826 if (strEQ(d,"truncate")) return -KEY_truncate;
4833 if (strEQ(d,"uc")) return -KEY_uc;
4836 if (strEQ(d,"use")) return KEY_use;
4839 if (strEQ(d,"undef")) return KEY_undef;
4840 if (strEQ(d,"until")) return KEY_until;
4841 if (strEQ(d,"untie")) return KEY_untie;
4842 if (strEQ(d,"utime")) return -KEY_utime;
4843 if (strEQ(d,"umask")) return -KEY_umask;
4846 if (strEQ(d,"unless")) return KEY_unless;
4847 if (strEQ(d,"unpack")) return -KEY_unpack;
4848 if (strEQ(d,"unlink")) return -KEY_unlink;
4851 if (strEQ(d,"unshift")) return KEY_unshift;
4852 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4857 if (strEQ(d,"values")) return -KEY_values;
4858 if (strEQ(d,"vec")) return -KEY_vec;
4863 if (strEQ(d,"warn")) return -KEY_warn;
4864 if (strEQ(d,"wait")) return -KEY_wait;
4867 if (strEQ(d,"while")) return KEY_while;
4868 if (strEQ(d,"write")) return -KEY_write;
4871 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4874 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4879 if (len == 1) return -KEY_x;
4880 if (strEQ(d,"xor")) return -KEY_xor;
4883 if (len == 1) return KEY_y;
4892 checkcomma(pTHX_ register char *s, char *name, char *what)
4896 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4897 dTHR; /* only for ckWARN */
4898 if (ckWARN(WARN_SYNTAX)) {
4900 for (w = s+2; *w && level; w++) {
4907 for (; *w && isSPACE(*w); w++) ;
4908 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4909 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4912 while (s < PL_bufend && isSPACE(*s))
4916 while (s < PL_bufend && isSPACE(*s))
4918 if (isIDFIRST_lazy(s)) {
4920 while (isALNUM_lazy(s))
4922 while (s < PL_bufend && isSPACE(*s))
4927 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
4931 croak("No comma allowed after %s", what);
4937 new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4940 HV *table = GvHV(PL_hintgv); /* ^H */
4943 bool oldcatch = CATCH_GET;
4948 yyerror("%^H is not defined");
4951 cvp = hv_fetch(table, key, strlen(key), FALSE);
4952 if (!cvp || !SvOK(*cvp)) {
4954 sprintf(buf,"$^H{%s} is not defined", key);
4958 sv_2mortal(sv); /* Parent created it permanently */
4961 pv = sv_2mortal(newSVpvn(s, len));
4963 typesv = sv_2mortal(newSVpv(type, 0));
4965 typesv = &PL_sv_undef;
4967 Zero(&myop, 1, BINOP);
4968 myop.op_last = (OP *) &myop;
4969 myop.op_next = Nullop;
4970 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4972 PUSHSTACKi(PERLSI_OVERLOAD);
4975 PL_op = (OP *) &myop;
4976 if (PERLDB_SUB && PL_curstash != PL_debstash)
4977 PL_op->op_private |= OPpENTERSUB_DB;
4988 if (PL_op = pp_entersub(ARGS))
4995 CATCH_SET(oldcatch);
5000 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5003 return SvREFCNT_inc(res);
5007 scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5009 register char *d = dest;
5010 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5013 croak(ident_too_long);
5014 if (isALNUM(*s)) /* UTF handled below */
5016 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5021 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5025 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5026 char *t = s + UTF8SKIP(s);
5027 while (*t & 0x80 && is_utf8_mark((U8*)t))
5029 if (d + (t - s) > e)
5030 croak(ident_too_long);
5031 Copy(s, d, t - s, char);
5044 scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5051 if (PL_lex_brackets == 0)
5052 PL_lex_fakebrack = 0;
5056 e = d + destlen - 3; /* two-character token, ending NUL */
5058 while (isDIGIT(*s)) {
5060 croak(ident_too_long);
5067 croak(ident_too_long);
5068 if (isALNUM(*s)) /* UTF handled below */
5070 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5075 else if (*s == ':' && s[1] == ':') {
5079 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5080 char *t = s + UTF8SKIP(s);
5081 while (*t & 0x80 && is_utf8_mark((U8*)t))
5083 if (d + (t - s) > e)
5084 croak(ident_too_long);
5085 Copy(s, d, t - s, char);
5096 if (PL_lex_state != LEX_NORMAL)
5097 PL_lex_state = LEX_INTERPENDMAYBE;
5100 if (*s == '$' && s[1] &&
5101 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5114 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5119 if (isSPACE(s[-1])) {
5122 if (ch != ' ' && ch != '\t') {
5128 if (isIDFIRST_lazy(d)) {
5132 while (e < send && isALNUM_lazy(e) || *e == ':') {
5134 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5137 Copy(s, d, e - s, char);
5142 while ((isALNUM(*s) || *s == ':') && d < e)
5145 croak(ident_too_long);
5148 while (s < send && (*s == ' ' || *s == '\t')) s++;
5149 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5150 dTHR; /* only for ckWARN */
5151 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5152 char *brack = *s == '[' ? "[...]" : "{...}";
5153 warner(WARN_AMBIGUOUS,
5154 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5155 funny, dest, brack, funny, dest, brack);
5157 PL_lex_fakebrack = PL_lex_brackets+1;
5159 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5163 /* Handle extended ${^Foo} variables
5164 * 1999-02-27 mjd-perl-patch@plover.com */
5165 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5169 while (isALNUM(*s) && d < e) {
5173 croak(ident_too_long);
5178 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5179 PL_lex_state = LEX_INTERPEND;
5182 if (PL_lex_state == LEX_NORMAL) {
5183 dTHR; /* only for ckWARN */
5184 if (ckWARN(WARN_AMBIGUOUS) &&
5185 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5187 warner(WARN_AMBIGUOUS,
5188 "Ambiguous use of %c{%s} resolved to %c%s",
5189 funny, dest, funny, dest);
5194 s = bracket; /* let the parser handle it */
5198 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5199 PL_lex_state = LEX_INTERPEND;
5203 void pmflag(U16 *pmfl, int ch)
5208 *pmfl |= PMf_GLOBAL;
5210 *pmfl |= PMf_CONTINUE;
5214 *pmfl |= PMf_MULTILINE;
5216 *pmfl |= PMf_SINGLELINE;
5218 *pmfl |= PMf_EXTENDED;
5222 scan_pat(pTHX_ char *start, I32 type)
5227 s = scan_str(start);
5230 SvREFCNT_dec(PL_lex_stuff);
5231 PL_lex_stuff = Nullsv;
5232 croak("Search pattern not terminated");
5235 pm = (PMOP*)newPMOP(type, 0);
5236 if (PL_multi_open == '?')
5237 pm->op_pmflags |= PMf_ONCE;
5239 while (*s && strchr("iomsx", *s))
5240 pmflag(&pm->op_pmflags,*s++);
5243 while (*s && strchr("iogcmsx", *s))
5244 pmflag(&pm->op_pmflags,*s++);
5246 pm->op_pmpermflags = pm->op_pmflags;
5248 PL_lex_op = (OP*)pm;
5249 yylval.ival = OP_MATCH;
5254 scan_subst(pTHX_ char *start)
5261 yylval.ival = OP_NULL;
5263 s = scan_str(start);
5267 SvREFCNT_dec(PL_lex_stuff);
5268 PL_lex_stuff = Nullsv;
5269 croak("Substitution pattern not terminated");
5272 if (s[-1] == PL_multi_open)
5275 first_start = PL_multi_start;
5279 SvREFCNT_dec(PL_lex_stuff);
5280 PL_lex_stuff = Nullsv;
5282 SvREFCNT_dec(PL_lex_repl);
5283 PL_lex_repl = Nullsv;
5284 croak("Substitution replacement not terminated");
5286 PL_multi_start = first_start; /* so whole substitution is taken together */
5288 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5294 else if (strchr("iogcmsx", *s))
5295 pmflag(&pm->op_pmflags,*s++);
5302 PL_sublex_info.super_bufptr = s;
5303 PL_sublex_info.super_bufend = PL_bufend;
5305 pm->op_pmflags |= PMf_EVAL;
5306 repl = newSVpvn("",0);
5308 sv_catpv(repl, es ? "eval " : "do ");
5309 sv_catpvn(repl, "{ ", 2);
5310 sv_catsv(repl, PL_lex_repl);
5311 sv_catpvn(repl, " };", 2);
5313 SvREFCNT_dec(PL_lex_repl);
5317 pm->op_pmpermflags = pm->op_pmflags;
5318 PL_lex_op = (OP*)pm;
5319 yylval.ival = OP_SUBST;
5324 scan_trans(pTHX_ char *start)
5335 yylval.ival = OP_NULL;
5337 s = scan_str(start);
5340 SvREFCNT_dec(PL_lex_stuff);
5341 PL_lex_stuff = Nullsv;
5342 croak("Transliteration pattern not terminated");
5344 if (s[-1] == PL_multi_open)
5350 SvREFCNT_dec(PL_lex_stuff);
5351 PL_lex_stuff = Nullsv;
5353 SvREFCNT_dec(PL_lex_repl);
5354 PL_lex_repl = Nullsv;
5355 croak("Transliteration replacement not terminated");
5359 o = newSVOP(OP_TRANS, 0, 0);
5360 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5363 New(803,tbl,256,short);
5364 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5368 complement = del = squash = 0;
5369 while (strchr("cdsCU", *s)) {
5371 complement = OPpTRANS_COMPLEMENT;
5373 del = OPpTRANS_DELETE;
5375 squash = OPpTRANS_SQUASH;
5380 utf8 &= ~OPpTRANS_FROM_UTF;
5382 utf8 |= OPpTRANS_FROM_UTF;
5386 utf8 &= ~OPpTRANS_TO_UTF;
5388 utf8 |= OPpTRANS_TO_UTF;
5391 croak("Too many /C and /U options");
5396 o->op_private = del|squash|complement|utf8;
5399 yylval.ival = OP_TRANS;
5404 scan_heredoc(pTHX_ register char *s)
5408 I32 op_type = OP_SCALAR;
5415 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5419 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5422 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5423 if (*peek && strchr("`'\"",*peek)) {
5426 s = delimcpy(d, e, s, PL_bufend, term, &len);
5436 if (!isALNUM_lazy(s))
5437 deprecate("bare << to mean <<\"\"");
5438 for (; isALNUM_lazy(s); s++) {
5443 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5444 croak("Delimiter for here document is too long");
5447 len = d - PL_tokenbuf;
5448 #ifndef PERL_STRICT_CR
5449 d = strchr(s, '\r');
5453 while (s < PL_bufend) {
5459 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5468 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5473 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5474 herewas = newSVpvn(s,PL_bufend-s);
5476 s--, herewas = newSVpvn(s,d-s);
5477 s += SvCUR(herewas);
5479 tmpstr = NEWSV(87,79);
5480 sv_upgrade(tmpstr, SVt_PVIV);
5485 else if (term == '`') {
5486 op_type = OP_BACKTICK;
5487 SvIVX(tmpstr) = '\\';
5491 PL_multi_start = PL_curcop->cop_line;
5492 PL_multi_open = PL_multi_close = '<';
5493 term = *PL_tokenbuf;
5494 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5495 char *bufptr = PL_sublex_info.super_bufptr;
5496 char *bufend = PL_sublex_info.super_bufend;
5497 char *olds = s - SvCUR(herewas);
5498 s = strchr(bufptr, '\n');
5502 while (s < bufend &&
5503 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5505 PL_curcop->cop_line++;
5508 PL_curcop->cop_line = PL_multi_start;
5509 missingterm(PL_tokenbuf);
5511 sv_setpvn(herewas,bufptr,d-bufptr+1);
5512 sv_setpvn(tmpstr,d+1,s-d);
5514 sv_catpvn(herewas,s,bufend-s);
5515 (void)strcpy(bufptr,SvPVX(herewas));
5522 while (s < PL_bufend &&
5523 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5525 PL_curcop->cop_line++;
5527 if (s >= PL_bufend) {
5528 PL_curcop->cop_line = PL_multi_start;
5529 missingterm(PL_tokenbuf);
5531 sv_setpvn(tmpstr,d+1,s-d);
5533 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5535 sv_catpvn(herewas,s,PL_bufend-s);
5536 sv_setsv(PL_linestr,herewas);
5537 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5538 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5541 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5542 while (s >= PL_bufend) { /* multiple line string? */
5544 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5545 PL_curcop->cop_line = PL_multi_start;
5546 missingterm(PL_tokenbuf);
5548 PL_curcop->cop_line++;
5549 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5550 #ifndef PERL_STRICT_CR
5551 if (PL_bufend - PL_linestart >= 2) {
5552 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5553 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5555 PL_bufend[-2] = '\n';
5557 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5559 else if (PL_bufend[-1] == '\r')
5560 PL_bufend[-1] = '\n';
5562 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5563 PL_bufend[-1] = '\n';
5565 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5566 SV *sv = NEWSV(88,0);
5568 sv_upgrade(sv, SVt_PVMG);
5569 sv_setsv(sv,PL_linestr);
5570 av_store(GvAV(PL_curcop->cop_filegv),
5571 (I32)PL_curcop->cop_line,sv);
5573 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5576 sv_catsv(PL_linestr,herewas);
5577 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5581 sv_catsv(tmpstr,PL_linestr);
5586 PL_multi_end = PL_curcop->cop_line;
5587 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5588 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5589 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5591 SvREFCNT_dec(herewas);
5592 PL_lex_stuff = tmpstr;
5593 yylval.ival = op_type;
5598 takes: current position in input buffer
5599 returns: new position in input buffer
5600 side-effects: yylval and lex_op are set.
5605 <FH> read from filehandle
5606 <pkg::FH> read from package qualified filehandle
5607 <pkg'FH> read from package qualified filehandle
5608 <$fh> read from filehandle in $fh
5614 scan_inputsymbol(pTHX_ char *start)
5616 register char *s = start; /* current position in buffer */
5622 d = PL_tokenbuf; /* start of temp holding space */
5623 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5624 end = strchr(s, '\n');
5627 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
5629 /* die if we didn't have space for the contents of the <>,
5630 or if it didn't end, or if we see a newline
5633 if (len >= sizeof PL_tokenbuf)
5634 croak("Excessively long <> operator");
5636 croak("Unterminated <> operator");
5641 Remember, only scalar variables are interpreted as filehandles by
5642 this code. Anything more complex (e.g., <$fh{$num}>) will be
5643 treated as a glob() call.
5644 This code makes use of the fact that except for the $ at the front,
5645 a scalar variable and a filehandle look the same.
5647 if (*d == '$' && d[1]) d++;
5649 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5650 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5653 /* If we've tried to read what we allow filehandles to look like, and
5654 there's still text left, then it must be a glob() and not a getline.
5655 Use scan_str to pull out the stuff between the <> and treat it
5656 as nothing more than a string.
5659 if (d - PL_tokenbuf != len) {
5660 yylval.ival = OP_GLOB;
5662 s = scan_str(start);
5664 croak("Glob not terminated");
5668 /* we're in a filehandle read situation */
5671 /* turn <> into <ARGV> */
5673 (void)strcpy(d,"ARGV");
5675 /* if <$fh>, create the ops to turn the variable into a
5681 /* try to find it in the pad for this block, otherwise find
5682 add symbol table ops
5684 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5685 OP *o = newOP(OP_PADSV, 0);
5687 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5690 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5691 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5692 newUNOP(OP_RV2SV, 0,
5693 newGVOP(OP_GV, 0, gv)));
5695 PL_lex_op->op_flags |= OPf_SPECIAL;
5696 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5697 yylval.ival = OP_NULL;
5700 /* If it's none of the above, it must be a literal filehandle
5701 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5703 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5704 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5705 yylval.ival = OP_NULL;
5714 takes: start position in buffer
5715 returns: position to continue reading from buffer
5716 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5717 updates the read buffer.
5719 This subroutine pulls a string out of the input. It is called for:
5720 q single quotes q(literal text)
5721 ' single quotes 'literal text'
5722 qq double quotes qq(interpolate $here please)
5723 " double quotes "interpolate $here please"
5724 qx backticks qx(/bin/ls -l)
5725 ` backticks `/bin/ls -l`
5726 qw quote words @EXPORT_OK = qw( func() $spam )
5727 m// regexp match m/this/
5728 s/// regexp substitute s/this/that/
5729 tr/// string transliterate tr/this/that/
5730 y/// string transliterate y/this/that/
5731 ($*@) sub prototypes sub foo ($)
5732 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5734 In most of these cases (all but <>, patterns and transliterate)
5735 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5736 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5737 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5740 It skips whitespace before the string starts, and treats the first
5741 character as the delimiter. If the delimiter is one of ([{< then
5742 the corresponding "close" character )]}> is used as the closing
5743 delimiter. It allows quoting of delimiters, and if the string has
5744 balanced delimiters ([{<>}]) it allows nesting.
5746 The lexer always reads these strings into lex_stuff, except in the
5747 case of the operators which take *two* arguments (s/// and tr///)
5748 when it checks to see if lex_stuff is full (presumably with the 1st
5749 arg to s or tr) and if so puts the string into lex_repl.
5754 scan_str(pTHX_ char *start)
5757 SV *sv; /* scalar value: string */
5758 char *tmps; /* temp string, used for delimiter matching */
5759 register char *s = start; /* current position in the buffer */
5760 register char term; /* terminating character */
5761 register char *to; /* current position in the sv's data */
5762 I32 brackets = 1; /* bracket nesting level */
5764 /* skip space before the delimiter */
5768 /* mark where we are, in case we need to report errors */
5771 /* after skipping whitespace, the next character is the terminator */
5773 /* mark where we are */
5774 PL_multi_start = PL_curcop->cop_line;
5775 PL_multi_open = term;
5777 /* find corresponding closing delimiter */
5778 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5780 PL_multi_close = term;
5782 /* create a new SV to hold the contents. 87 is leak category, I'm
5783 assuming. 79 is the SV's initial length. What a random number. */
5785 sv_upgrade(sv, SVt_PVIV);
5787 (void)SvPOK_only(sv); /* validate pointer */
5789 /* move past delimiter and try to read a complete string */
5792 /* extend sv if need be */
5793 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5794 /* set 'to' to the next character in the sv's string */
5795 to = SvPVX(sv)+SvCUR(sv);
5797 /* if open delimiter is the close delimiter read unbridle */
5798 if (PL_multi_open == PL_multi_close) {
5799 for (; s < PL_bufend; s++,to++) {
5800 /* embedded newlines increment the current line number */
5801 if (*s == '\n' && !PL_rsfp)
5802 PL_curcop->cop_line++;
5803 /* handle quoted delimiters */
5804 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5807 /* any other quotes are simply copied straight through */
5811 /* terminate when run out of buffer (the for() condition), or
5812 have found the terminator */
5813 else if (*s == term)
5819 /* if the terminator isn't the same as the start character (e.g.,
5820 matched brackets), we have to allow more in the quoting, and
5821 be prepared for nested brackets.
5824 /* read until we run out of string, or we find the terminator */
5825 for (; s < PL_bufend; s++,to++) {
5826 /* embedded newlines increment the line count */
5827 if (*s == '\n' && !PL_rsfp)
5828 PL_curcop->cop_line++;
5829 /* backslashes can escape the open or closing characters */
5830 if (*s == '\\' && s+1 < PL_bufend) {
5831 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5836 /* allow nested opens and closes */
5837 else if (*s == PL_multi_close && --brackets <= 0)
5839 else if (*s == PL_multi_open)
5844 /* terminate the copied string and update the sv's end-of-string */
5846 SvCUR_set(sv, to - SvPVX(sv));
5849 * this next chunk reads more into the buffer if we're not done yet
5852 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5854 #ifndef PERL_STRICT_CR
5855 if (to - SvPVX(sv) >= 2) {
5856 if ((to[-2] == '\r' && to[-1] == '\n') ||
5857 (to[-2] == '\n' && to[-1] == '\r'))
5861 SvCUR_set(sv, to - SvPVX(sv));
5863 else if (to[-1] == '\r')
5866 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5870 /* if we're out of file, or a read fails, bail and reset the current
5871 line marker so we can report where the unterminated string began
5874 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5876 PL_curcop->cop_line = PL_multi_start;
5879 /* we read a line, so increment our line counter */
5880 PL_curcop->cop_line++;
5882 /* update debugger info */
5883 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5884 SV *sv = NEWSV(88,0);
5886 sv_upgrade(sv, SVt_PVMG);
5887 sv_setsv(sv,PL_linestr);
5888 av_store(GvAV(PL_curcop->cop_filegv),
5889 (I32)PL_curcop->cop_line, sv);
5892 /* having changed the buffer, we must update PL_bufend */
5893 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5896 /* at this point, we have successfully read the delimited string */
5898 PL_multi_end = PL_curcop->cop_line;
5901 /* if we allocated too much space, give some back */
5902 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5903 SvLEN_set(sv, SvCUR(sv) + 1);
5904 Renew(SvPVX(sv), SvLEN(sv), char);
5907 /* decide whether this is the first or second quoted string we've read
5920 takes: pointer to position in buffer
5921 returns: pointer to new position in buffer
5922 side-effects: builds ops for the constant in yylval.op
5924 Read a number in any of the formats that Perl accepts:
5926 0(x[0-7A-F]+)|([0-7]+)|(b[01])
5927 [\d_]+(\.[\d_]*)?[Ee](\d+)
5929 Underbars (_) are allowed in decimal numbers. If -w is on,
5930 underbars before a decimal point must be at three digit intervals.
5932 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5935 If it reads a number without a decimal point or an exponent, it will
5936 try converting the number to an integer and see if it can do so
5937 without loss of precision.
5941 Perl_scan_num(pTHX_ char *start)
5943 register char *s = start; /* current position in buffer */
5944 register char *d; /* destination in temp buffer */
5945 register char *e; /* end of temp buffer */
5946 I32 tryiv; /* used to see if it can be an int */
5947 double value; /* number read, as a double */
5948 SV *sv; /* place to put the converted number */
5949 I32 floatit; /* boolean: int or float? */
5950 char *lastub = 0; /* position of last underbar */
5951 static char number_too_long[] = "Number too long";
5953 /* We use the first character to decide what type of number this is */
5957 croak("panic: scan_num");
5959 /* if it starts with a 0, it could be an octal number, a decimal in
5960 0.13 disguise, or a hexadecimal number, or a binary number.
5965 u holds the "number so far"
5966 shift the power of 2 of the base
5967 (hex == 4, octal == 3, binary == 1)
5968 overflowed was the number more than we can hold?
5970 Shift is used when we add a digit. It also serves as an "are
5971 we in octal/hex/binary?" indicator to disallow hex characters
5976 bool overflowed = FALSE;
5982 } else if (s[1] == 'b') {
5986 /* check for a decimal in disguise */
5987 else if (s[1] == '.')
5989 /* so it must be octal */
5994 /* read the rest of the number */
5996 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
6000 /* if we don't mention it, we're done */
6009 /* 8 and 9 are not octal */
6012 yyerror(form("Illegal octal digit '%c'", *s));
6015 yyerror(form("Illegal binary digit '%c'", *s));
6019 case '2': case '3': case '4':
6020 case '5': case '6': case '7':
6022 yyerror(form("Illegal binary digit '%c'", *s));
6026 b = *s++ & 15; /* ASCII digit -> value of digit */
6030 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6031 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6032 /* make sure they said 0x */
6037 /* Prepare to put the digit we have onto the end
6038 of the number so far. We check for overflows.
6042 n = u << shift; /* make room for the digit */
6043 if (!overflowed && (n >> shift) != u
6044 && !(PL_hints & HINT_NEW_BINARY)) {
6045 warn("Integer overflow in %s number",
6046 (shift == 4) ? "hex"
6047 : ((shift == 3) ? "octal" : "binary"));
6050 u = n | b; /* add the digit to the end */
6055 /* if we get here, we had success: make a scalar value from
6061 if ( PL_hints & HINT_NEW_BINARY)
6062 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6067 handle decimal numbers.
6068 we're also sent here when we read a 0 as the first digit
6070 case '1': case '2': case '3': case '4': case '5':
6071 case '6': case '7': case '8': case '9': case '.':
6074 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6077 /* read next group of digits and _ and copy into d */
6078 while (isDIGIT(*s) || *s == '_') {
6079 /* skip underscores, checking for misplaced ones
6083 dTHR; /* only for ckWARN */
6084 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6085 warner(WARN_SYNTAX, "Misplaced _ in number");
6089 /* check for end of fixed-length buffer */
6091 croak(number_too_long);
6092 /* if we're ok, copy the character */
6097 /* final misplaced underbar check */
6098 if (lastub && s - lastub != 3) {
6100 if (ckWARN(WARN_SYNTAX))
6101 warner(WARN_SYNTAX, "Misplaced _ in number");
6104 /* read a decimal portion if there is one. avoid
6105 3..5 being interpreted as the number 3. followed
6108 if (*s == '.' && s[1] != '.') {
6112 /* copy, ignoring underbars, until we run out of
6113 digits. Note: no misplaced underbar checks!
6115 for (; isDIGIT(*s) || *s == '_'; s++) {
6116 /* fixed length buffer check */
6118 croak(number_too_long);
6124 /* read exponent part, if present */
6125 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6129 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6130 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6132 /* allow positive or negative exponent */
6133 if (*s == '+' || *s == '-')
6136 /* read digits of exponent (no underbars :-) */
6137 while (isDIGIT(*s)) {
6139 croak(number_too_long);
6144 /* terminate the string */
6147 /* make an sv from the string */
6149 /* reset numeric locale in case we were earlier left in Swaziland */
6150 SET_NUMERIC_STANDARD();
6151 value = atof(PL_tokenbuf);
6154 See if we can make do with an integer value without loss of
6155 precision. We use I_V to cast to an int, because some
6156 compilers have issues. Then we try casting it back and see
6157 if it was the same. We only do this if we know we
6158 specifically read an integer.
6160 Note: if floatit is true, then we don't need to do the
6164 if (!floatit && (double)tryiv == value)
6165 sv_setiv(sv, tryiv);
6167 sv_setnv(sv, value);
6168 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6169 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6170 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6174 /* make the op for the constant and return */
6176 yylval.opval = newSVOP(OP_CONST, 0, sv);
6182 scan_formline(pTHX_ register char *s)
6187 SV *stuff = newSVpvn("",0);
6188 bool needargs = FALSE;
6191 if (*s == '.' || *s == '}') {
6193 #ifdef PERL_STRICT_CR
6194 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6196 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6198 if (*t == '\n' || t == PL_bufend)
6201 if (PL_in_eval && !PL_rsfp) {
6202 eol = strchr(s,'\n');
6207 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6209 for (t = s; t < eol; t++) {
6210 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6212 goto enough; /* ~~ must be first line in formline */
6214 if (*t == '@' || *t == '^')
6217 sv_catpvn(stuff, s, eol-s);
6221 s = filter_gets(PL_linestr, PL_rsfp, 0);
6222 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6223 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6226 yyerror("Format not terminated");
6236 PL_lex_state = LEX_NORMAL;
6237 PL_nextval[PL_nexttoke].ival = 0;
6241 PL_lex_state = LEX_FORMLINE;
6242 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6244 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6248 SvREFCNT_dec(stuff);
6249 PL_lex_formbrack = 0;
6260 PL_cshlen = strlen(PL_cshname);
6265 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6268 I32 oldsavestack_ix = PL_savestack_ix;
6269 CV* outsidecv = PL_compcv;
6273 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6275 save_I32(&PL_subline);
6276 save_item(PL_subname);
6278 SAVESPTR(PL_curpad);
6279 SAVESPTR(PL_comppad);
6280 SAVESPTR(PL_comppad_name);
6281 SAVESPTR(PL_compcv);
6282 SAVEI32(PL_comppad_name_fill);
6283 SAVEI32(PL_min_intro_pending);
6284 SAVEI32(PL_max_intro_pending);
6285 SAVEI32(PL_pad_reset_pending);
6287 PL_compcv = (CV*)NEWSV(1104,0);
6288 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6289 CvFLAGS(PL_compcv) |= flags;
6291 PL_comppad = newAV();
6292 av_push(PL_comppad, Nullsv);
6293 PL_curpad = AvARRAY(PL_comppad);
6294 PL_comppad_name = newAV();
6295 PL_comppad_name_fill = 0;
6296 PL_min_intro_pending = 0;
6298 PL_subline = PL_curcop->cop_line;
6300 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6301 PL_curpad[0] = (SV*)newAV();
6302 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6303 #endif /* USE_THREADS */
6305 comppadlist = newAV();
6306 AvREAL_off(comppadlist);
6307 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6308 av_store(comppadlist, 1, (SV*)PL_comppad);
6310 CvPADLIST(PL_compcv) = comppadlist;
6311 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6313 CvOWNER(PL_compcv) = 0;
6314 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6315 MUTEX_INIT(CvMUTEXP(PL_compcv));
6316 #endif /* USE_THREADS */
6318 return oldsavestack_ix;
6322 Perl_yywarn(pTHX_ char *s)
6326 PL_in_eval |= EVAL_WARNONLY;
6328 PL_in_eval &= ~EVAL_WARNONLY;
6333 Perl_yyerror(pTHX_ char *s)
6337 char *context = NULL;
6341 if (!yychar || (yychar == ';' && !PL_rsfp))
6343 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6344 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6345 while (isSPACE(*PL_oldoldbufptr))
6347 context = PL_oldoldbufptr;
6348 contlen = PL_bufptr - PL_oldoldbufptr;
6350 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6351 PL_oldbufptr != PL_bufptr) {
6352 while (isSPACE(*PL_oldbufptr))
6354 context = PL_oldbufptr;
6355 contlen = PL_bufptr - PL_oldbufptr;
6357 else if (yychar > 255)
6358 where = "next token ???";
6359 else if ((yychar & 127) == 127) {
6360 if (PL_lex_state == LEX_NORMAL ||
6361 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6362 where = "at end of line";
6363 else if (PL_lex_inpat)
6364 where = "within pattern";
6366 where = "within string";
6369 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6371 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6372 else if (isPRINT_LC(yychar))
6373 sv_catpvf(where_sv, "%c", yychar);
6375 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6376 where = SvPVX(where_sv);
6378 msg = sv_2mortal(newSVpv(s, 0));
6379 sv_catpvf(msg, " at %_ line %ld, ",
6380 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6382 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6384 sv_catpvf(msg, "%s\n", where);
6385 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6387 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6388 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6391 if (PL_in_eval & EVAL_WARNONLY)
6393 else if (PL_in_eval)
6394 sv_catsv(ERRSV, msg);
6396 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6397 if (++PL_error_count >= 10)
6398 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6400 PL_in_my_stash = Nullhv;