3 * Copyright (c) 1991-1999, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It all comes from here, the stench and the peril." --Frodo
15 #define PERL_IN_TOKE_C
18 #define yychar PL_yychar
19 #define yylval PL_yylval
21 static char ident_too_long[] = "Identifier too long";
23 #define UTF (PL_hints & HINT_UTF8)
25 * Note: we try to be careful never to call the isXXX_utf8() functions
26 * unless we're pretty sure we've seen the beginning of a UTF-8 character
27 * (that is, the two high bits are set). Otherwise we risk loading in the
28 * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
30 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
32 : isIDFIRST_utf8((U8*)p))
33 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
35 : isALNUM_utf8((U8*)p))
37 /* In variables name $^X, these are the legal values for X.
38 * 1999-02-27 mjd-perl-patch@plover.com */
39 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
41 /* The following are arranged oddly so that the guard on the switch statement
42 * can get by with a single comparison (if the compiler is smart enough).
45 /* #define LEX_NOTPARSING 11 is done in perl.h. */
48 #define LEX_INTERPNORMAL 9
49 #define LEX_INTERPCASEMOD 8
50 #define LEX_INTERPPUSH 7
51 #define LEX_INTERPSTART 6
52 #define LEX_INTERPEND 5
53 #define LEX_INTERPENDMAYBE 4
54 #define LEX_INTERPCONCAT 3
55 #define LEX_INTERPCONST 2
56 #define LEX_FORMLINE 1
57 #define LEX_KNOWNEXT 0
66 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
68 # include <unistd.h> /* Needed for execv() */
77 YYSTYPE* yylval_pointer = NULL;
78 int* yychar_pointer = NULL;
81 # define yylval (*yylval_pointer)
82 # define yychar (*yychar_pointer)
83 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
85 # define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
93 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
95 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
96 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
97 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
98 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
99 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
100 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
101 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
102 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
103 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
104 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
105 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
106 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
107 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
108 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
109 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
110 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
111 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
112 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
113 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
114 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
116 /* This bit of chicanery makes a unary function followed by
117 * a parenthesis into a function with one argument, highest precedence.
119 #define UNI(f) return(yylval.ival = f, \
122 PL_last_uni = PL_oldbufptr, \
123 PL_last_lop_op = f, \
124 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
126 #define UNIBRACK(f) return(yylval.ival = f, \
128 PL_last_uni = PL_oldbufptr, \
129 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
131 /* grandfather return to old style */
132 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
135 S_ao(pTHX_ int toketype)
137 if (*PL_bufptr == '=') {
139 if (toketype == ANDAND)
140 yylval.ival = OP_ANDASSIGN;
141 else if (toketype == OROR)
142 yylval.ival = OP_ORASSIGN;
149 S_no_op(pTHX_ char *what, char *s)
151 char *oldbp = PL_bufptr;
152 bool is_first = (PL_oldbufptr == PL_linestart);
155 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
157 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
158 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
160 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
161 if (t < PL_bufptr && isSPACE(*t))
162 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
163 t - PL_oldoldbufptr, PL_oldoldbufptr);
167 Perl_warn(aTHX_ "\t(Missing operator before end of line?)\n");
169 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
174 S_missingterm(pTHX_ char *s)
179 char *nl = strrchr(s,'\n');
185 iscntrl(PL_multi_close)
187 PL_multi_close < 32 || PL_multi_close == 127
191 tmpbuf[1] = toCTRL(PL_multi_close);
197 *tmpbuf = PL_multi_close;
201 q = strchr(s,'"') ? '\'' : '"';
202 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
206 Perl_deprecate(pTHX_ char *s)
209 if (ckWARN(WARN_DEPRECATED))
210 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
216 deprecate("comma-less variable list");
222 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
224 I32 count = FILTER_READ(idx+1, sv, maxlen);
225 if (count > 0 && !maxlen)
226 win32_strip_return(sv);
232 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
234 I32 count = FILTER_READ(idx+1, sv, maxlen);
238 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
239 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
240 sv_usepvn(sv, (char*)tmps, tend - tmps);
247 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
249 I32 count = FILTER_READ(idx+1, sv, maxlen);
253 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
254 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
255 sv_usepvn(sv, (char*)tmps, tend - tmps);
262 Perl_lex_start(pTHX_ SV *line)
268 SAVEI32(PL_lex_dojoin);
269 SAVEI32(PL_lex_brackets);
270 SAVEI32(PL_lex_fakebrack);
271 SAVEI32(PL_lex_casemods);
272 SAVEI32(PL_lex_starts);
273 SAVEI32(PL_lex_state);
274 SAVESPTR(PL_lex_inpat);
275 SAVEI32(PL_lex_inwhat);
276 SAVEI16(PL_curcop->cop_line);
279 SAVEPPTR(PL_oldbufptr);
280 SAVEPPTR(PL_oldoldbufptr);
281 SAVEPPTR(PL_linestart);
282 SAVESPTR(PL_linestr);
283 SAVEPPTR(PL_lex_brackstack);
284 SAVEPPTR(PL_lex_casestack);
285 SAVEDESTRUCTOR(S_restore_rsfp, PL_rsfp);
286 SAVESPTR(PL_lex_stuff);
287 SAVEI32(PL_lex_defer);
288 SAVESPTR(PL_lex_repl);
289 SAVEDESTRUCTOR(S_restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
290 SAVEDESTRUCTOR(S_restore_lex_expect, PL_tokenbuf + PL_expect);
292 PL_lex_state = LEX_NORMAL;
296 PL_lex_fakebrack = 0;
297 New(899, PL_lex_brackstack, 120, char);
298 New(899, PL_lex_casestack, 12, char);
299 SAVEFREEPV(PL_lex_brackstack);
300 SAVEFREEPV(PL_lex_casestack);
302 *PL_lex_casestack = '\0';
305 PL_lex_stuff = Nullsv;
306 PL_lex_repl = Nullsv;
310 if (SvREADONLY(PL_linestr))
311 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
312 s = SvPV(PL_linestr, len);
313 if (len && s[len-1] != ';') {
314 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
315 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
316 sv_catpvn(PL_linestr, "\n;", 2);
318 SvTEMP_off(PL_linestr);
319 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
320 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
322 PL_rs = newSVpvn("\n", 1);
329 PL_doextract = FALSE;
333 S_restore_rsfp(pTHX_ void *f)
335 PerlIO *fp = (PerlIO*)f;
337 if (PL_rsfp == PerlIO_stdin())
338 PerlIO_clearerr(PL_rsfp);
339 else if (PL_rsfp && (PL_rsfp != fp))
340 PerlIO_close(PL_rsfp);
345 S_restore_expect(pTHX_ void *e)
347 /* a safe way to store a small integer in a pointer */
348 PL_expect = (expectation)((char *)e - PL_tokenbuf);
352 S_restore_lex_expect(pTHX_ void *e)
354 /* a safe way to store a small integer in a pointer */
355 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
359 S_incline(pTHX_ char *s)
367 PL_curcop->cop_line++;
370 while (*s == ' ' || *s == '\t') s++;
371 if (strnEQ(s, "line ", 5)) {
380 while (*s == ' ' || *s == '\t')
382 if (*s == '"' && (t = strchr(s+1, '"')))
386 return; /* false alarm */
387 for (t = s; !isSPACE(*t); t++) ;
392 PL_curcop->cop_filegv = gv_fetchfile(s);
394 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
396 PL_curcop->cop_line = atoi(n)-1;
400 S_skipspace(pTHX_ register char *s)
403 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
404 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
410 while (s < PL_bufend && isSPACE(*s)) {
411 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
414 if (s < PL_bufend && *s == '#') {
415 while (s < PL_bufend && *s != '\n')
419 if (PL_in_eval && !PL_rsfp) {
425 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
427 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
428 if (PL_minus_n || PL_minus_p) {
429 sv_setpv(PL_linestr,PL_minus_p ?
430 ";}continue{print or die qq(-p destination: $!\\n)" :
432 sv_catpv(PL_linestr,";}");
433 PL_minus_n = PL_minus_p = 0;
436 sv_setpv(PL_linestr,";");
437 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
438 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
439 if (PL_preprocess && !PL_in_eval)
440 (void)PerlProc_pclose(PL_rsfp);
441 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
442 PerlIO_clearerr(PL_rsfp);
444 (void)PerlIO_close(PL_rsfp);
448 PL_linestart = PL_bufptr = s + prevlen;
449 PL_bufend = s + SvCUR(PL_linestr);
452 if (PERLDB_LINE && PL_curstash != PL_debstash) {
453 SV *sv = NEWSV(85,0);
455 sv_upgrade(sv, SVt_PVMG);
456 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
457 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
469 if (PL_oldoldbufptr != PL_last_uni)
471 while (isSPACE(*PL_last_uni))
473 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
474 if ((t = strchr(s, '(')) && t < PL_bufptr)
478 Perl_warn(aTHX_ "Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
485 #define UNI(f) return uni(f,s)
488 S_uni(pTHX_ I32 f, char *s)
493 PL_last_uni = PL_oldbufptr;
504 #endif /* CRIPPLED_CC */
506 #define LOP(f,x) return lop(f,x,s)
509 S_lop(pTHX_ I32 f, expectation x, char *s)
516 PL_last_lop = PL_oldbufptr;
530 S_force_next(pTHX_ I32 type)
532 PL_nexttype[PL_nexttoke] = type;
534 if (PL_lex_state != LEX_KNOWNEXT) {
535 PL_lex_defer = PL_lex_state;
536 PL_lex_expect = PL_expect;
537 PL_lex_state = LEX_KNOWNEXT;
542 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
547 start = skipspace(start);
549 if (isIDFIRST_lazy(s) ||
550 (allow_pack && *s == ':') ||
551 (allow_initial_tick && *s == '\'') )
553 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
554 if (check_keyword && keyword(PL_tokenbuf, len))
556 if (token == METHOD) {
561 PL_expect = XOPERATOR;
564 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
565 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
572 S_force_ident(pTHX_ register char *s, int kind)
575 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
576 PL_nextval[PL_nexttoke].opval = o;
579 dTHR; /* just for in_eval */
580 o->op_private = OPpCONST_ENTERED;
581 /* XXX see note in pp_entereval() for why we forgo typo
582 warnings if the symbol must be introduced in an eval.
584 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
585 kind == '$' ? SVt_PV :
586 kind == '@' ? SVt_PVAV :
587 kind == '%' ? SVt_PVHV :
595 S_force_version(pTHX_ char *s)
597 OP *version = Nullop;
601 /* default VERSION number -- GBARR */
606 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
607 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
609 /* real VERSION number -- GBARR */
610 version = yylval.opval;
614 /* NOTE: The parser sees the package name and the VERSION swapped */
615 PL_nextval[PL_nexttoke].opval = version;
622 S_tokeq(pTHX_ SV *sv)
633 s = SvPV_force(sv, len);
637 while (s < send && *s != '\\')
642 if ( PL_hints & HINT_NEW_STRING )
643 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
646 if (s + 1 < send && (s[1] == '\\'))
647 s++; /* all that, just for this */
652 SvCUR_set(sv, d - SvPVX(sv));
654 if ( PL_hints & HINT_NEW_STRING )
655 return new_constant(NULL, 0, "q", sv, pv, "q");
662 register I32 op_type = yylval.ival;
664 if (op_type == OP_NULL) {
665 yylval.opval = PL_lex_op;
669 if (op_type == OP_CONST || op_type == OP_READLINE) {
670 SV *sv = tokeq(PL_lex_stuff);
672 if (SvTYPE(sv) == SVt_PVIV) {
673 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
679 nsv = newSVpvn(p, len);
683 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
684 PL_lex_stuff = Nullsv;
688 PL_sublex_info.super_state = PL_lex_state;
689 PL_sublex_info.sub_inwhat = op_type;
690 PL_sublex_info.sub_op = PL_lex_op;
691 PL_lex_state = LEX_INTERPPUSH;
695 yylval.opval = PL_lex_op;
709 PL_lex_state = PL_sublex_info.super_state;
710 SAVEI32(PL_lex_dojoin);
711 SAVEI32(PL_lex_brackets);
712 SAVEI32(PL_lex_fakebrack);
713 SAVEI32(PL_lex_casemods);
714 SAVEI32(PL_lex_starts);
715 SAVEI32(PL_lex_state);
716 SAVESPTR(PL_lex_inpat);
717 SAVEI32(PL_lex_inwhat);
718 SAVEI16(PL_curcop->cop_line);
720 SAVEPPTR(PL_oldbufptr);
721 SAVEPPTR(PL_oldoldbufptr);
722 SAVEPPTR(PL_linestart);
723 SAVESPTR(PL_linestr);
724 SAVEPPTR(PL_lex_brackstack);
725 SAVEPPTR(PL_lex_casestack);
727 PL_linestr = PL_lex_stuff;
728 PL_lex_stuff = Nullsv;
730 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
731 PL_bufend += SvCUR(PL_linestr);
732 SAVEFREESV(PL_linestr);
734 PL_lex_dojoin = FALSE;
736 PL_lex_fakebrack = 0;
737 New(899, PL_lex_brackstack, 120, char);
738 New(899, PL_lex_casestack, 12, char);
739 SAVEFREEPV(PL_lex_brackstack);
740 SAVEFREEPV(PL_lex_casestack);
742 *PL_lex_casestack = '\0';
744 PL_lex_state = LEX_INTERPCONCAT;
745 PL_curcop->cop_line = PL_multi_start;
747 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
748 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
749 PL_lex_inpat = PL_sublex_info.sub_op;
751 PL_lex_inpat = Nullop;
759 if (!PL_lex_starts++) {
760 PL_expect = XOPERATOR;
761 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
765 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
766 PL_lex_state = LEX_INTERPCASEMOD;
770 /* Is there a right-hand side to take care of? */
771 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
772 PL_linestr = PL_lex_repl;
774 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
775 PL_bufend += SvCUR(PL_linestr);
776 SAVEFREESV(PL_linestr);
777 PL_lex_dojoin = FALSE;
779 PL_lex_fakebrack = 0;
781 *PL_lex_casestack = '\0';
783 if (SvEVALED(PL_lex_repl)) {
784 PL_lex_state = LEX_INTERPNORMAL;
786 /* we don't clear PL_lex_repl here, so that we can check later
787 whether this is an evalled subst; that means we rely on the
788 logic to ensure sublex_done() is called again only via the
789 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
792 PL_lex_state = LEX_INTERPCONCAT;
793 PL_lex_repl = Nullsv;
799 PL_bufend = SvPVX(PL_linestr);
800 PL_bufend += SvCUR(PL_linestr);
801 PL_expect = XOPERATOR;
809 Extracts a pattern, double-quoted string, or transliteration. This
812 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
813 processing a pattern (PL_lex_inpat is true), a transliteration
814 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
816 Returns a pointer to the character scanned up to. Iff this is
817 advanced from the start pointer supplied (ie if anything was
818 successfully parsed), will leave an OP for the substring scanned
819 in yylval. Caller must intuit reason for not parsing further
820 by looking at the next characters herself.
824 double-quoted style: \r and \n
825 regexp special ones: \D \s
827 backrefs: \1 (deprecated in substitution replacements)
828 case and quoting: \U \Q \E
829 stops on @ and $, but not for $ as tail anchor
832 characters are VERY literal, except for - not at the start or end
833 of the string, which indicates a range. scan_const expands the
834 range to the full set of intermediate characters.
836 In double-quoted strings:
838 double-quoted style: \r and \n
840 backrefs: \1 (deprecated)
841 case and quoting: \U \Q \E
844 scan_const does *not* construct ops to handle interpolated strings.
845 It stops processing as soon as it finds an embedded $ or @ variable
846 and leaves it to the caller to work out what's going on.
848 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
850 $ in pattern could be $foo or could be tail anchor. Assumption:
851 it's a tail anchor if $ is the last thing in the string, or if it's
852 followed by one of ")| \n\t"
854 \1 (backreferences) are turned into $1
856 The structure of the code is
857 while (there's a character to process) {
858 handle transliteration ranges
860 skip # initiated comments in //x patterns
861 check for embedded @foo
862 check for embedded scalars
864 leave intact backslashes from leave (below)
865 deprecate \1 in strings and sub replacements
866 handle string-changing backslashes \l \U \Q \E, etc.
867 switch (what was escaped) {
868 handle - in a transliteration (becomes a literal -)
869 handle \132 octal characters
870 handle 0x15 hex characters
871 handle \cV (control V)
872 handle printf backslashes (\f, \r, \n, etc)
875 } (end while character to read)
880 S_scan_const(pTHX_ char *start)
882 register char *send = PL_bufend; /* end of the constant */
883 SV *sv = NEWSV(93, send - start); /* sv for the constant */
884 register char *s = start; /* start of the constant */
885 register char *d = SvPVX(sv); /* destination for copies */
886 bool dorange = FALSE; /* are we in a translit range? */
888 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
889 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
891 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
892 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
895 /* leaveit is the set of acceptably-backslashed characters */
898 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
901 while (s < send || dorange) {
902 /* get transliterations out of the way (they're most literal) */
903 if (PL_lex_inwhat == OP_TRANS) {
904 /* expand a range A-Z to the full set of characters. AIE! */
906 I32 i; /* current expanded character */
907 I32 min; /* first character in range */
908 I32 max; /* last character in range */
910 i = d - SvPVX(sv); /* remember current offset */
911 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
912 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
913 d -= 2; /* eat the first char and the - */
915 min = (U8)*d; /* first char in range */
916 max = (U8)d[1]; /* last char in range */
919 if ((isLOWER(min) && isLOWER(max)) ||
920 (isUPPER(min) && isUPPER(max))) {
922 for (i = min; i <= max; i++)
926 for (i = min; i <= max; i++)
933 for (i = min; i <= max; i++)
936 /* mark the range as done, and continue */
941 /* range begins (ignore - as first or last char) */
942 else if (*s == '-' && s+1 < send && s != start) {
944 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
953 /* if we get here, we're not doing a transliteration */
955 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
956 except for the last char, which will be done separately. */
957 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
959 while (s < send && *s != ')')
961 } else if (s[2] == '{'
962 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
964 char *regparse = s + (s[2] == '{' ? 3 : 4);
967 while (count && (c = *regparse)) {
968 if (c == '\\' && regparse[1])
976 if (*regparse != ')') {
977 regparse--; /* Leave one char for continuation. */
978 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
985 /* likewise skip #-initiated comments in //x patterns */
986 else if (*s == '#' && PL_lex_inpat &&
987 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
988 while (s+1 < send && *s != '\n')
992 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
993 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
996 /* check for embedded scalars. only stop if we're sure it's a
999 else if (*s == '$') {
1000 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1002 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1003 break; /* in regexp, $ might be tail anchor */
1006 /* (now in tr/// code again) */
1008 if (*s & 0x80 && thisutf) {
1009 dTHR; /* only for ckWARN */
1010 if (ckWARN(WARN_UTF8)) {
1011 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1021 if (*s == '\\' && s+1 < send) {
1024 /* some backslashes we leave behind */
1025 if (*leaveit && *s && strchr(leaveit, *s)) {
1031 /* deprecate \1 in strings and substitution replacements */
1032 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1033 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1035 dTHR; /* only for ckWARN */
1036 if (ckWARN(WARN_SYNTAX))
1037 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1042 /* string-change backslash escapes */
1043 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1048 /* if we get here, it's either a quoted -, or a digit */
1051 /* quoted - in transliterations */
1053 if (PL_lex_inwhat == OP_TRANS) {
1061 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1062 Perl_warner(aTHX_ WARN_UNSAFE,
1063 "Unrecognized escape \\%c passed through",
1065 /* default action is to copy the quoted character */
1070 /* \132 indicates an octal constant */
1071 case '0': case '1': case '2': case '3':
1072 case '4': case '5': case '6': case '7':
1073 *d++ = scan_oct(s, 3, &len);
1077 /* \x24 indicates a hex constant */
1081 char* e = strchr(s, '}');
1084 yyerror("Missing right brace on \\x{}");
1089 if (ckWARN(WARN_UTF8))
1090 Perl_warner(aTHX_ WARN_UTF8,
1091 "Use of \\x{} without utf8 declaration");
1093 /* note: utf always shorter than hex */
1094 d = (char*)uv_to_utf8((U8*)d,
1095 scan_hex(s + 1, e - s - 1, &len));
1100 UV uv = (UV)scan_hex(s, 2, &len);
1101 if (utf && PL_lex_inwhat == OP_TRANS &&
1102 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1104 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1107 if (uv >= 127 && UTF) {
1109 if (ckWARN(WARN_UTF8))
1110 Perl_warner(aTHX_ WARN_UTF8,
1111 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1120 /* \c is a control character */
1134 /* printf-style backslashes, formfeeds, newlines, etc */
1160 } /* end if (backslash) */
1163 } /* while loop to process each character */
1165 /* terminate the string and set up the sv */
1167 SvCUR_set(sv, d - SvPVX(sv));
1170 /* shrink the sv if we allocated more than we used */
1171 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1172 SvLEN_set(sv, SvCUR(sv) + 1);
1173 Renew(SvPVX(sv), SvLEN(sv), char);
1176 /* return the substring (via yylval) only if we parsed anything */
1177 if (s > PL_bufptr) {
1178 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1179 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1181 ( PL_lex_inwhat == OP_TRANS
1183 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1186 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1192 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1194 S_intuit_more(pTHX_ register char *s)
1196 if (PL_lex_brackets)
1198 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1200 if (*s != '{' && *s != '[')
1205 /* In a pattern, so maybe we have {n,m}. */
1222 /* On the other hand, maybe we have a character class */
1225 if (*s == ']' || *s == '^')
1228 int weight = 2; /* let's weigh the evidence */
1230 unsigned char un_char = 255, last_un_char;
1231 char *send = strchr(s,']');
1232 char tmpbuf[sizeof PL_tokenbuf * 4];
1234 if (!send) /* has to be an expression */
1237 Zero(seen,256,char);
1240 else if (isDIGIT(*s)) {
1242 if (isDIGIT(s[1]) && s[2] == ']')
1248 for (; s < send; s++) {
1249 last_un_char = un_char;
1250 un_char = (unsigned char)*s;
1255 weight -= seen[un_char] * 10;
1256 if (isALNUM_lazy(s+1)) {
1257 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1258 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1263 else if (*s == '$' && s[1] &&
1264 strchr("[#!%*<>()-=",s[1])) {
1265 if (/*{*/ strchr("])} =",s[2]))
1274 if (strchr("wds]",s[1]))
1276 else if (seen['\''] || seen['"'])
1278 else if (strchr("rnftbxcav",s[1]))
1280 else if (isDIGIT(s[1])) {
1282 while (s[1] && isDIGIT(s[1]))
1292 if (strchr("aA01! ",last_un_char))
1294 if (strchr("zZ79~",s[1]))
1296 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1297 weight -= 5; /* cope with negative subscript */
1300 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1301 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1306 if (keyword(tmpbuf, d - tmpbuf))
1309 if (un_char == last_un_char + 1)
1311 weight -= seen[un_char];
1316 if (weight >= 0) /* probably a character class */
1324 S_intuit_method(pTHX_ char *start, GV *gv)
1326 char *s = start + (*start == '$');
1327 char tmpbuf[sizeof PL_tokenbuf];
1335 if ((cv = GvCVu(gv))) {
1336 char *proto = SvPVX(cv);
1346 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1347 if (*start == '$') {
1348 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1353 return *s == '(' ? FUNCMETH : METHOD;
1355 if (!keyword(tmpbuf, len)) {
1356 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1361 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1362 if (indirgv && GvCVu(indirgv))
1364 /* filehandle or package name makes it a method */
1365 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1367 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1368 return 0; /* no assumptions -- "=>" quotes bearword */
1370 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1371 newSVpvn(tmpbuf,len));
1372 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1376 return *s == '(' ? FUNCMETH : METHOD;
1386 char *pdb = PerlEnv_getenv("PERL5DB");
1390 SETERRNO(0,SS$_NORMAL);
1391 return "BEGIN { require 'perl5db.pl' }";
1397 /* Encoded script support. filter_add() effectively inserts a
1398 * 'pre-processing' function into the current source input stream.
1399 * Note that the filter function only applies to the current source file
1400 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1402 * The datasv parameter (which may be NULL) can be used to pass
1403 * private data to this instance of the filter. The filter function
1404 * can recover the SV using the FILTER_DATA macro and use it to
1405 * store private buffers and state information.
1407 * The supplied datasv parameter is upgraded to a PVIO type
1408 * and the IoDIRP field is used to store the function pointer.
1409 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1410 * private use must be set using malloc'd pointers.
1414 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1416 if (!funcp){ /* temporary handy debugging hack to be deleted */
1417 PL_filter_debug = atoi((char*)datasv);
1420 if (!PL_rsfp_filters)
1421 PL_rsfp_filters = newAV();
1423 datasv = NEWSV(255,0);
1424 if (!SvUPGRADE(datasv, SVt_PVIO))
1425 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1426 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1427 if (PL_filter_debug) {
1429 Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1431 av_unshift(PL_rsfp_filters, 1);
1432 av_store(PL_rsfp_filters, 0, datasv) ;
1437 /* Delete most recently added instance of this filter function. */
1439 Perl_filter_del(pTHX_ filter_t funcp)
1441 if (PL_filter_debug)
1442 Perl_warn(aTHX_ "filter_del func %p", funcp);
1443 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1445 /* if filter is on top of stack (usual case) just pop it off */
1446 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1447 IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1448 sv_free(av_pop(PL_rsfp_filters));
1452 /* we need to search for the correct entry and clear it */
1453 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1457 /* Invoke the n'th filter function for the current rsfp. */
1459 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1462 /* 0 = read one text line */
1467 if (!PL_rsfp_filters)
1469 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1470 /* Provide a default input filter to make life easy. */
1471 /* Note that we append to the line. This is handy. */
1472 if (PL_filter_debug)
1473 Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
1477 int old_len = SvCUR(buf_sv) ;
1479 /* ensure buf_sv is large enough */
1480 SvGROW(buf_sv, old_len + maxlen) ;
1481 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1482 if (PerlIO_error(PL_rsfp))
1483 return -1; /* error */
1485 return 0 ; /* end of file */
1487 SvCUR_set(buf_sv, old_len + len) ;
1490 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1491 if (PerlIO_error(PL_rsfp))
1492 return -1; /* error */
1494 return 0 ; /* end of file */
1497 return SvCUR(buf_sv);
1499 /* Skip this filter slot if filter has been deleted */
1500 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1501 if (PL_filter_debug)
1502 Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
1503 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1505 /* Get function pointer hidden within datasv */
1506 funcp = (filter_t)IoDIRP(datasv);
1507 if (PL_filter_debug) {
1509 Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
1510 idx, funcp, SvPV(datasv,n_a));
1512 /* Call function. The function is expected to */
1513 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1514 /* Return: <0:error, =0:eof, >0:not eof */
1515 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
1519 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1522 if (!PL_rsfp_filters) {
1523 filter_add(win32_textfilter,NULL);
1526 if (PL_rsfp_filters) {
1529 SvCUR_set(sv, 0); /* start with empty line */
1530 if (FILTER_READ(0, sv, 0) > 0)
1531 return ( SvPVX(sv) ) ;
1536 return (sv_gets(sv, fp, append));
1541 static char* exp_name[] =
1542 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1548 Works out what to call the token just pulled out of the input
1549 stream. The yacc parser takes care of taking the ops we return and
1550 stitching them into a tree.
1556 if read an identifier
1557 if we're in a my declaration
1558 croak if they tried to say my($foo::bar)
1559 build the ops for a my() declaration
1560 if it's an access to a my() variable
1561 are we in a sort block?
1562 croak if my($a); $a <=> $b
1563 build ops for access to a my() variable
1564 if in a dq string, and they've said @foo and we can't find @foo
1566 build ops for a bareword
1567 if we already built the token before, use it.
1571 #ifdef USE_PURE_BISON
1572 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1585 #ifdef USE_PURE_BISON
1586 yylval_pointer = lvalp;
1587 yychar_pointer = lcharp;
1590 /* check if there's an identifier for us to look at */
1591 if (PL_pending_ident) {
1592 /* pit holds the identifier we read and pending_ident is reset */
1593 char pit = PL_pending_ident;
1594 PL_pending_ident = 0;
1596 /* if we're in a my(), we can't allow dynamics here.
1597 $foo'bar has already been turned into $foo::bar, so
1598 just check for colons.
1600 if it's a legal name, the OP is a PADANY.
1603 if (strchr(PL_tokenbuf,':'))
1604 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1606 yylval.opval = newOP(OP_PADANY, 0);
1607 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1612 build the ops for accesses to a my() variable.
1614 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1615 then used in a comparison. This catches most, but not
1616 all cases. For instance, it catches
1617 sort { my($a); $a <=> $b }
1619 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1620 (although why you'd do that is anyone's guess).
1623 if (!strchr(PL_tokenbuf,':')) {
1625 /* Check for single character per-thread SVs */
1626 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1627 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1628 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1630 yylval.opval = newOP(OP_THREADSV, 0);
1631 yylval.opval->op_targ = tmp;
1634 #endif /* USE_THREADS */
1635 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1636 /* if it's a sort block and they're naming $a or $b */
1637 if (PL_last_lop_op == OP_SORT &&
1638 PL_tokenbuf[0] == '$' &&
1639 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1642 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1643 d < PL_bufend && *d != '\n';
1646 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1647 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
1653 yylval.opval = newOP(OP_PADANY, 0);
1654 yylval.opval->op_targ = tmp;
1660 Whine if they've said @foo in a doublequoted string,
1661 and @foo isn't a variable we can find in the symbol
1664 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1665 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1666 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1667 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
1668 PL_tokenbuf, PL_tokenbuf));
1671 /* build ops for a bareword */
1672 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1673 yylval.opval->op_private = OPpCONST_ENTERED;
1674 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1675 ((PL_tokenbuf[0] == '$') ? SVt_PV
1676 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1681 /* no identifier pending identification */
1683 switch (PL_lex_state) {
1685 case LEX_NORMAL: /* Some compilers will produce faster */
1686 case LEX_INTERPNORMAL: /* code if we comment these out. */
1690 /* when we're already built the next token, just pull it out the queue */
1693 yylval = PL_nextval[PL_nexttoke];
1695 PL_lex_state = PL_lex_defer;
1696 PL_expect = PL_lex_expect;
1697 PL_lex_defer = LEX_NORMAL;
1699 return(PL_nexttype[PL_nexttoke]);
1701 /* interpolated case modifiers like \L \U, including \Q and \E.
1702 when we get here, PL_bufptr is at the \
1704 case LEX_INTERPCASEMOD:
1706 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1707 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
1709 /* handle \E or end of string */
1710 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1714 if (PL_lex_casemods) {
1715 oldmod = PL_lex_casestack[--PL_lex_casemods];
1716 PL_lex_casestack[PL_lex_casemods] = '\0';
1718 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1720 PL_lex_state = LEX_INTERPCONCAT;
1724 if (PL_bufptr != PL_bufend)
1726 PL_lex_state = LEX_INTERPCONCAT;
1731 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1732 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1733 if (strchr("LU", *s) &&
1734 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1736 PL_lex_casestack[--PL_lex_casemods] = '\0';
1739 if (PL_lex_casemods > 10) {
1740 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1741 if (newlb != PL_lex_casestack) {
1743 PL_lex_casestack = newlb;
1746 PL_lex_casestack[PL_lex_casemods++] = *s;
1747 PL_lex_casestack[PL_lex_casemods] = '\0';
1748 PL_lex_state = LEX_INTERPCONCAT;
1749 PL_nextval[PL_nexttoke].ival = 0;
1752 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1754 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1756 PL_nextval[PL_nexttoke].ival = OP_LC;
1758 PL_nextval[PL_nexttoke].ival = OP_UC;
1760 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1762 Perl_croak(aTHX_ "panic: yylex");
1765 if (PL_lex_starts) {
1774 case LEX_INTERPPUSH:
1775 return sublex_push();
1777 case LEX_INTERPSTART:
1778 if (PL_bufptr == PL_bufend)
1779 return sublex_done();
1781 PL_lex_dojoin = (*PL_bufptr == '@');
1782 PL_lex_state = LEX_INTERPNORMAL;
1783 if (PL_lex_dojoin) {
1784 PL_nextval[PL_nexttoke].ival = 0;
1787 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1788 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1789 force_next(PRIVATEREF);
1791 force_ident("\"", '$');
1792 #endif /* USE_THREADS */
1793 PL_nextval[PL_nexttoke].ival = 0;
1795 PL_nextval[PL_nexttoke].ival = 0;
1797 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1800 if (PL_lex_starts++) {
1806 case LEX_INTERPENDMAYBE:
1807 if (intuit_more(PL_bufptr)) {
1808 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1814 if (PL_lex_dojoin) {
1815 PL_lex_dojoin = FALSE;
1816 PL_lex_state = LEX_INTERPCONCAT;
1819 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
1820 && SvEVALED(PL_lex_repl))
1822 if (PL_bufptr != PL_bufend)
1823 Perl_croak(aTHX_ "Bad evalled substitution pattern");
1824 PL_lex_repl = Nullsv;
1827 case LEX_INTERPCONCAT:
1829 if (PL_lex_brackets)
1830 Perl_croak(aTHX_ "panic: INTERPCONCAT");
1832 if (PL_bufptr == PL_bufend)
1833 return sublex_done();
1835 if (SvIVX(PL_linestr) == '\'') {
1836 SV *sv = newSVsv(PL_linestr);
1839 else if ( PL_hints & HINT_NEW_RE )
1840 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1841 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1845 s = scan_const(PL_bufptr);
1847 PL_lex_state = LEX_INTERPCASEMOD;
1849 PL_lex_state = LEX_INTERPSTART;
1852 if (s != PL_bufptr) {
1853 PL_nextval[PL_nexttoke] = yylval;
1856 if (PL_lex_starts++)
1866 PL_lex_state = LEX_NORMAL;
1867 s = scan_formline(PL_bufptr);
1868 if (!PL_lex_formbrack)
1874 PL_oldoldbufptr = PL_oldbufptr;
1877 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1883 if (isIDFIRST_lazy(s))
1885 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
1888 goto fake_eof; /* emulate EOF on ^D or ^Z */
1893 if (PL_lex_brackets)
1894 yyerror("Missing right curly or square bracket");
1897 if (s++ < PL_bufend)
1898 goto retry; /* ignore stray nulls */
1901 if (!PL_in_eval && !PL_preambled) {
1902 PL_preambled = TRUE;
1903 sv_setpv(PL_linestr,incl_perldb());
1904 if (SvCUR(PL_linestr))
1905 sv_catpv(PL_linestr,";");
1907 while(AvFILLp(PL_preambleav) >= 0) {
1908 SV *tmpsv = av_shift(PL_preambleav);
1909 sv_catsv(PL_linestr, tmpsv);
1910 sv_catpv(PL_linestr, ";");
1913 sv_free((SV*)PL_preambleav);
1914 PL_preambleav = NULL;
1916 if (PL_minus_n || PL_minus_p) {
1917 sv_catpv(PL_linestr, "LINE: while (<>) {");
1919 sv_catpv(PL_linestr,"chomp;");
1921 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1923 GvIMPORTED_AV_on(gv);
1925 if (strchr("/'\"", *PL_splitstr)
1926 && strchr(PL_splitstr + 1, *PL_splitstr))
1927 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
1930 s = "'~#\200\1'"; /* surely one char is unused...*/
1931 while (s[1] && strchr(PL_splitstr, *s)) s++;
1933 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
1934 "q" + (delim == '\''), delim);
1935 for (s = PL_splitstr; *s; s++) {
1937 sv_catpvn(PL_linestr, "\\", 1);
1938 sv_catpvn(PL_linestr, s, 1);
1940 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
1944 sv_catpv(PL_linestr,"@F=split(' ');");
1947 sv_catpv(PL_linestr, "\n");
1948 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1949 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1950 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1951 SV *sv = NEWSV(85,0);
1953 sv_upgrade(sv, SVt_PVMG);
1954 sv_setsv(sv,PL_linestr);
1955 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1960 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1963 if (PL_preprocess && !PL_in_eval)
1964 (void)PerlProc_pclose(PL_rsfp);
1965 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1966 PerlIO_clearerr(PL_rsfp);
1968 (void)PerlIO_close(PL_rsfp);
1970 PL_doextract = FALSE;
1972 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1973 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1974 sv_catpv(PL_linestr,";}");
1975 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1976 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1977 PL_minus_n = PL_minus_p = 0;
1980 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1981 sv_setpv(PL_linestr,"");
1982 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1985 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1986 PL_doextract = FALSE;
1988 /* Incest with pod. */
1989 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1990 sv_setpv(PL_linestr, "");
1991 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1992 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1993 PL_doextract = FALSE;
1997 } while (PL_doextract);
1998 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1999 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2000 SV *sv = NEWSV(85,0);
2002 sv_upgrade(sv, SVt_PVMG);
2003 sv_setsv(sv,PL_linestr);
2004 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2006 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2007 if (PL_curcop->cop_line == 1) {
2008 while (s < PL_bufend && isSPACE(*s))
2010 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2014 if (*s == '#' && *(s+1) == '!')
2016 #ifdef ALTERNATE_SHEBANG
2018 static char as[] = ALTERNATE_SHEBANG;
2019 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2020 d = s + (sizeof(as) - 1);
2022 #endif /* ALTERNATE_SHEBANG */
2031 while (*d && !isSPACE(*d))
2035 #ifdef ARG_ZERO_IS_SCRIPT
2036 if (ipathend > ipath) {
2038 * HP-UX (at least) sets argv[0] to the script name,
2039 * which makes $^X incorrect. And Digital UNIX and Linux,
2040 * at least, set argv[0] to the basename of the Perl
2041 * interpreter. So, having found "#!", we'll set it right.
2043 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2044 assert(SvPOK(x) || SvGMAGICAL(x));
2045 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2046 sv_setpvn(x, ipath, ipathend - ipath);
2049 TAINT_NOT; /* $^X is always tainted, but that's OK */
2051 #endif /* ARG_ZERO_IS_SCRIPT */
2056 d = instr(s,"perl -");
2058 d = instr(s,"perl");
2059 #ifdef ALTERNATE_SHEBANG
2061 * If the ALTERNATE_SHEBANG on this system starts with a
2062 * character that can be part of a Perl expression, then if
2063 * we see it but not "perl", we're probably looking at the
2064 * start of Perl code, not a request to hand off to some
2065 * other interpreter. Similarly, if "perl" is there, but
2066 * not in the first 'word' of the line, we assume the line
2067 * contains the start of the Perl program.
2069 if (d && *s != '#') {
2071 while (*c && !strchr("; \t\r\n\f\v#", *c))
2074 d = Nullch; /* "perl" not in first word; ignore */
2076 *s = '#'; /* Don't try to parse shebang line */
2078 #endif /* ALTERNATE_SHEBANG */
2083 !instr(s,"indir") &&
2084 instr(PL_origargv[0],"perl"))
2090 while (s < PL_bufend && isSPACE(*s))
2092 if (s < PL_bufend) {
2093 Newz(899,newargv,PL_origargc+3,char*);
2095 while (s < PL_bufend && !isSPACE(*s))
2098 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2101 newargv = PL_origargv;
2103 PerlProc_execv(ipath, newargv);
2104 Perl_croak(aTHX_ "Can't exec %s", ipath);
2107 U32 oldpdb = PL_perldb;
2108 bool oldn = PL_minus_n;
2109 bool oldp = PL_minus_p;
2111 while (*d && !isSPACE(*d)) d++;
2112 while (*d == ' ' || *d == '\t') d++;
2116 if (*d == 'M' || *d == 'm') {
2118 while (*d && !isSPACE(*d)) d++;
2119 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2122 d = moreswitches(d);
2124 if (PERLDB_LINE && !oldpdb ||
2125 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2126 /* if we have already added "LINE: while (<>) {",
2127 we must not do it again */
2129 sv_setpv(PL_linestr, "");
2130 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2131 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2132 PL_preambled = FALSE;
2134 (void)gv_fetchfile(PL_origfilename);
2141 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2143 PL_lex_state = LEX_FORMLINE;
2148 #ifdef PERL_STRICT_CR
2149 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2151 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2153 case ' ': case '\t': case '\f': case 013:
2158 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2160 while (s < d && *s != '\n')
2165 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2167 PL_lex_state = LEX_FORMLINE;
2177 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2182 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2185 if (strnEQ(s,"=>",2)) {
2186 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2187 OPERATOR('-'); /* unary minus */
2189 PL_last_uni = PL_oldbufptr;
2190 PL_last_lop_op = OP_FTEREAD; /* good enough */
2192 case 'r': FTST(OP_FTEREAD);
2193 case 'w': FTST(OP_FTEWRITE);
2194 case 'x': FTST(OP_FTEEXEC);
2195 case 'o': FTST(OP_FTEOWNED);
2196 case 'R': FTST(OP_FTRREAD);
2197 case 'W': FTST(OP_FTRWRITE);
2198 case 'X': FTST(OP_FTREXEC);
2199 case 'O': FTST(OP_FTROWNED);
2200 case 'e': FTST(OP_FTIS);
2201 case 'z': FTST(OP_FTZERO);
2202 case 's': FTST(OP_FTSIZE);
2203 case 'f': FTST(OP_FTFILE);
2204 case 'd': FTST(OP_FTDIR);
2205 case 'l': FTST(OP_FTLINK);
2206 case 'p': FTST(OP_FTPIPE);
2207 case 'S': FTST(OP_FTSOCK);
2208 case 'u': FTST(OP_FTSUID);
2209 case 'g': FTST(OP_FTSGID);
2210 case 'k': FTST(OP_FTSVTX);
2211 case 'b': FTST(OP_FTBLK);
2212 case 'c': FTST(OP_FTCHR);
2213 case 't': FTST(OP_FTTTY);
2214 case 'T': FTST(OP_FTTEXT);
2215 case 'B': FTST(OP_FTBINARY);
2216 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2217 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2218 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2220 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2227 if (PL_expect == XOPERATOR)
2232 else if (*s == '>') {
2235 if (isIDFIRST_lazy(s)) {
2236 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2244 if (PL_expect == XOPERATOR)
2247 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2249 OPERATOR('-'); /* unary minus */
2256 if (PL_expect == XOPERATOR)
2261 if (PL_expect == XOPERATOR)
2264 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2270 if (PL_expect != XOPERATOR) {
2271 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2272 PL_expect = XOPERATOR;
2273 force_ident(PL_tokenbuf, '*');
2286 if (PL_expect == XOPERATOR) {
2290 PL_tokenbuf[0] = '%';
2291 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2292 if (!PL_tokenbuf[1]) {
2294 yyerror("Final % should be \\% or %name");
2297 PL_pending_ident = '%';
2319 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2320 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2325 if (PL_curcop->cop_line < PL_copline)
2326 PL_copline = PL_curcop->cop_line;
2337 if (PL_lex_brackets <= 0)
2338 yyerror("Unmatched right square bracket");
2341 if (PL_lex_state == LEX_INTERPNORMAL) {
2342 if (PL_lex_brackets == 0) {
2343 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2344 PL_lex_state = LEX_INTERPEND;
2351 if (PL_lex_brackets > 100) {
2352 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2353 if (newlb != PL_lex_brackstack) {
2355 PL_lex_brackstack = newlb;
2358 switch (PL_expect) {
2360 if (PL_lex_formbrack) {
2364 if (PL_oldoldbufptr == PL_last_lop)
2365 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2367 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2368 OPERATOR(HASHBRACK);
2370 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2373 PL_tokenbuf[0] = '\0';
2374 if (d < PL_bufend && *d == '-') {
2375 PL_tokenbuf[0] = '-';
2377 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2380 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2381 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2383 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2386 char minus = (PL_tokenbuf[0] == '-');
2387 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2394 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2398 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2403 if (PL_oldoldbufptr == PL_last_lop)
2404 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2406 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2409 OPERATOR(HASHBRACK);
2410 /* This hack serves to disambiguate a pair of curlies
2411 * as being a block or an anon hash. Normally, expectation
2412 * determines that, but in cases where we're not in a
2413 * position to expect anything in particular (like inside
2414 * eval"") we have to resolve the ambiguity. This code
2415 * covers the case where the first term in the curlies is a
2416 * quoted string. Most other cases need to be explicitly
2417 * disambiguated by prepending a `+' before the opening
2418 * curly in order to force resolution as an anon hash.
2420 * XXX should probably propagate the outer expectation
2421 * into eval"" to rely less on this hack, but that could
2422 * potentially break current behavior of eval"".
2426 if (*s == '\'' || *s == '"' || *s == '`') {
2427 /* common case: get past first string, handling escapes */
2428 for (t++; t < PL_bufend && *t != *s;)
2429 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2433 else if (*s == 'q') {
2436 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2437 && !isALNUM(*t)))) {
2439 char open, close, term;
2442 while (t < PL_bufend && isSPACE(*t))
2446 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2450 for (t++; t < PL_bufend; t++) {
2451 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2453 else if (*t == open)
2457 for (t++; t < PL_bufend; t++) {
2458 if (*t == '\\' && t+1 < PL_bufend)
2460 else if (*t == close && --brackets <= 0)
2462 else if (*t == open)
2468 else if (isIDFIRST_lazy(s)) {
2469 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2471 while (t < PL_bufend && isSPACE(*t))
2473 /* if comma follows first term, call it an anon hash */
2474 /* XXX it could be a comma expression with loop modifiers */
2475 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2476 || (*t == '=' && t[1] == '>')))
2477 OPERATOR(HASHBRACK);
2478 if (PL_expect == XREF)
2479 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2481 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2487 yylval.ival = PL_curcop->cop_line;
2488 if (isSPACE(*s) || *s == '#')
2489 PL_copline = NOLINE; /* invalidate current command line number */
2494 if (PL_lex_brackets <= 0)
2495 yyerror("Unmatched right curly bracket");
2497 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2498 if (PL_lex_brackets < PL_lex_formbrack)
2499 PL_lex_formbrack = 0;
2500 if (PL_lex_state == LEX_INTERPNORMAL) {
2501 if (PL_lex_brackets == 0) {
2502 if (PL_lex_fakebrack) {
2503 PL_lex_state = LEX_INTERPEND;
2505 return yylex(); /* ignore fake brackets */
2507 if (*s == '-' && s[1] == '>')
2508 PL_lex_state = LEX_INTERPENDMAYBE;
2509 else if (*s != '[' && *s != '{')
2510 PL_lex_state = LEX_INTERPEND;
2513 if (PL_lex_brackets < PL_lex_fakebrack) {
2515 PL_lex_fakebrack = 0;
2516 return yylex(); /* ignore fake brackets */
2526 if (PL_expect == XOPERATOR) {
2527 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2528 PL_curcop->cop_line--;
2529 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
2530 PL_curcop->cop_line++;
2535 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2537 PL_expect = XOPERATOR;
2538 force_ident(PL_tokenbuf, '&');
2542 yylval.ival = (OPpENTERSUB_AMPER<<8);
2561 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2562 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2564 if (PL_expect == XSTATE && isALPHA(tmp) &&
2565 (s == PL_linestart+1 || s[-2] == '\n') )
2567 if (PL_in_eval && !PL_rsfp) {
2572 if (strnEQ(s,"=cut",4)) {
2586 PL_doextract = TRUE;
2589 if (PL_lex_brackets < PL_lex_formbrack) {
2591 #ifdef PERL_STRICT_CR
2592 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2594 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2596 if (*t == '\n' || *t == '#') {
2614 if (PL_expect != XOPERATOR) {
2615 if (s[1] != '<' && !strchr(s,'>'))
2618 s = scan_heredoc(s);
2620 s = scan_inputsymbol(s);
2621 TERM(sublex_start());
2626 SHop(OP_LEFT_SHIFT);
2640 SHop(OP_RIGHT_SHIFT);
2649 if (PL_expect == XOPERATOR) {
2650 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2653 return ','; /* grandfather non-comma-format format */
2657 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2658 if (PL_expect == XOPERATOR)
2659 no_op("Array length", PL_bufptr);
2660 PL_tokenbuf[0] = '@';
2661 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2663 if (!PL_tokenbuf[1])
2665 PL_expect = XOPERATOR;
2666 PL_pending_ident = '#';
2670 if (PL_expect == XOPERATOR)
2671 no_op("Scalar", PL_bufptr);
2672 PL_tokenbuf[0] = '$';
2673 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2674 if (!PL_tokenbuf[1]) {
2676 yyerror("Final $ should be \\$ or $name");
2680 /* This kludge not intended to be bulletproof. */
2681 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2682 yylval.opval = newSVOP(OP_CONST, 0,
2683 newSViv((IV)PL_compiling.cop_arybase));
2684 yylval.opval->op_private = OPpCONST_ARYBASE;
2690 if (PL_lex_state == LEX_NORMAL)
2693 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2696 PL_tokenbuf[0] = '@';
2697 if (ckWARN(WARN_SYNTAX)) {
2699 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2702 PL_bufptr = skipspace(PL_bufptr);
2703 while (t < PL_bufend && *t != ']')
2705 Perl_warner(aTHX_ WARN_SYNTAX,
2706 "Multidimensional syntax %.*s not supported",
2707 (t - PL_bufptr) + 1, PL_bufptr);
2711 else if (*s == '{') {
2712 PL_tokenbuf[0] = '%';
2713 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2714 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2716 char tmpbuf[sizeof PL_tokenbuf];
2718 for (t++; isSPACE(*t); t++) ;
2719 if (isIDFIRST_lazy(t)) {
2720 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2721 for (; isSPACE(*t); t++) ;
2722 if (*t == ';' && get_cv(tmpbuf, FALSE))
2723 Perl_warner(aTHX_ WARN_SYNTAX,
2724 "You need to quote \"%s\"", tmpbuf);
2730 PL_expect = XOPERATOR;
2731 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
2732 bool islop = (PL_last_lop == PL_oldoldbufptr);
2733 if (!islop || PL_last_lop_op == OP_GREPSTART)
2734 PL_expect = XOPERATOR;
2735 else if (strchr("$@\"'`q", *s))
2736 PL_expect = XTERM; /* e.g. print $fh "foo" */
2737 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2738 PL_expect = XTERM; /* e.g. print $fh &sub */
2739 else if (isIDFIRST_lazy(s)) {
2740 char tmpbuf[sizeof PL_tokenbuf];
2741 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2742 if (tmp = keyword(tmpbuf, len)) {
2743 /* binary operators exclude handle interpretations */
2755 PL_expect = XTERM; /* e.g. print $fh length() */
2760 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2761 if (gv && GvCVu(gv))
2762 PL_expect = XTERM; /* e.g. print $fh subr() */
2765 else if (isDIGIT(*s))
2766 PL_expect = XTERM; /* e.g. print $fh 3 */
2767 else if (*s == '.' && isDIGIT(s[1]))
2768 PL_expect = XTERM; /* e.g. print $fh .3 */
2769 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2770 PL_expect = XTERM; /* e.g. print $fh -1 */
2771 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2772 PL_expect = XTERM; /* print $fh <<"EOF" */
2774 PL_pending_ident = '$';
2778 if (PL_expect == XOPERATOR)
2780 PL_tokenbuf[0] = '@';
2781 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2782 if (!PL_tokenbuf[1]) {
2784 yyerror("Final @ should be \\@ or @name");
2787 if (PL_lex_state == LEX_NORMAL)
2789 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2791 PL_tokenbuf[0] = '%';
2793 /* Warn about @ where they meant $. */
2794 if (ckWARN(WARN_SYNTAX)) {
2795 if (*s == '[' || *s == '{') {
2797 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2799 if (*t == '}' || *t == ']') {
2801 PL_bufptr = skipspace(PL_bufptr);
2802 Perl_warner(aTHX_ WARN_SYNTAX,
2803 "Scalar value %.*s better written as $%.*s",
2804 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2809 PL_pending_ident = '@';
2812 case '/': /* may either be division or pattern */
2813 case '?': /* may either be conditional or pattern */
2814 if (PL_expect != XOPERATOR) {
2815 /* Disable warning on "study /blah/" */
2816 if (PL_oldoldbufptr == PL_last_uni
2817 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2818 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2820 s = scan_pat(s,OP_MATCH);
2821 TERM(sublex_start());
2829 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2830 #ifdef PERL_STRICT_CR
2833 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2835 && (s == PL_linestart || s[-1] == '\n') )
2837 PL_lex_formbrack = 0;
2841 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2847 yylval.ival = OPf_SPECIAL;
2853 if (PL_expect != XOPERATOR)
2858 case '0': case '1': case '2': case '3': case '4':
2859 case '5': case '6': case '7': case '8': case '9':
2861 if (PL_expect == XOPERATOR)
2867 if (PL_expect == XOPERATOR) {
2868 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2871 return ','; /* grandfather non-comma-format format */
2877 missingterm((char*)0);
2878 yylval.ival = OP_CONST;
2879 TERM(sublex_start());
2883 if (PL_expect == XOPERATOR) {
2884 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2887 return ','; /* grandfather non-comma-format format */
2893 missingterm((char*)0);
2894 yylval.ival = OP_CONST;
2895 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2896 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2897 yylval.ival = OP_STRINGIFY;
2901 TERM(sublex_start());
2905 if (PL_expect == XOPERATOR)
2906 no_op("Backticks",s);
2908 missingterm((char*)0);
2909 yylval.ival = OP_BACKTICK;
2911 TERM(sublex_start());
2915 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2916 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2918 if (PL_expect == XOPERATOR)
2919 no_op("Backslash",s);
2923 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2963 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2965 /* Some keywords can be followed by any delimiter, including ':' */
2966 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2967 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2968 (PL_tokenbuf[0] == 'q' &&
2969 strchr("qwxr", PL_tokenbuf[1]))));
2971 /* x::* is just a word, unless x is "CORE" */
2972 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2976 while (d < PL_bufend && isSPACE(*d))
2977 d++; /* no comments skipped here, or s### is misparsed */
2979 /* Is this a label? */
2980 if (!tmp && PL_expect == XSTATE
2981 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2983 yylval.pval = savepv(PL_tokenbuf);
2988 /* Check for keywords */
2989 tmp = keyword(PL_tokenbuf, len);
2991 /* Is this a word before a => operator? */
2992 if (strnEQ(d,"=>",2)) {
2994 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2995 yylval.opval->op_private = OPpCONST_BARE;
2999 if (tmp < 0) { /* second-class keyword? */
3000 GV *ogv = Nullgv; /* override (winner) */
3001 GV *hgv = Nullgv; /* hidden (loser) */
3002 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3004 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3007 if (GvIMPORTED_CV(gv))
3009 else if (! CvMETHOD(cv))
3013 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3014 (gv = *gvp) != (GV*)&PL_sv_undef &&
3015 GvCVu(gv) && GvIMPORTED_CV(gv))
3021 tmp = 0; /* overridden by import or by GLOBAL */
3024 && -tmp==KEY_lock /* XXX generalizable kludge */
3025 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3027 tmp = 0; /* any sub overrides "weak" keyword */
3029 else { /* no override */
3033 if (ckWARN(WARN_AMBIGUOUS) && hgv
3034 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3035 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3036 "Ambiguous call resolved as CORE::%s(), %s",
3037 GvENAME(hgv), "qualify as such or use &");
3044 default: /* not a keyword */
3047 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3049 /* Get the rest if it looks like a package qualifier */
3051 if (*s == '\'' || *s == ':' && s[1] == ':') {
3053 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3056 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3057 *s == '\'' ? "'" : "::");
3061 if (PL_expect == XOPERATOR) {
3062 if (PL_bufptr == PL_linestart) {
3063 PL_curcop->cop_line--;
3064 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3065 PL_curcop->cop_line++;
3068 no_op("Bareword",s);
3071 /* Look for a subroutine with this name in current package,
3072 unless name is "Foo::", in which case Foo is a bearword
3073 (and a package name). */
3076 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3078 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3079 Perl_warner(aTHX_ WARN_UNSAFE,
3080 "Bareword \"%s\" refers to nonexistent package",
3083 PL_tokenbuf[len] = '\0';
3090 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3093 /* if we saw a global override before, get the right name */
3096 sv = newSVpvn("CORE::GLOBAL::",14);
3097 sv_catpv(sv,PL_tokenbuf);
3100 sv = newSVpv(PL_tokenbuf,0);
3102 /* Presume this is going to be a bareword of some sort. */
3105 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3106 yylval.opval->op_private = OPpCONST_BARE;
3108 /* And if "Foo::", then that's what it certainly is. */
3113 /* See if it's the indirect object for a list operator. */
3115 if (PL_oldoldbufptr &&
3116 PL_oldoldbufptr < PL_bufptr &&
3117 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3118 /* NO SKIPSPACE BEFORE HERE! */
3119 (PL_expect == XREF ||
3120 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3122 bool immediate_paren = *s == '(';
3124 /* (Now we can afford to cross potential line boundary.) */
3127 /* Two barewords in a row may indicate method call. */
3129 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3132 /* If not a declared subroutine, it's an indirect object. */
3133 /* (But it's an indir obj regardless for sort.) */
3135 if ((PL_last_lop_op == OP_SORT ||
3136 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3137 (PL_last_lop_op != OP_MAPSTART &&
3138 PL_last_lop_op != OP_GREPSTART))
3140 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3145 /* If followed by a paren, it's certainly a subroutine. */
3147 PL_expect = XOPERATOR;
3151 if (gv && GvCVu(gv)) {
3152 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3153 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3158 PL_nextval[PL_nexttoke].opval = yylval.opval;
3159 PL_expect = XOPERATOR;
3165 /* If followed by var or block, call it a method (unless sub) */
3167 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3168 PL_last_lop = PL_oldbufptr;
3169 PL_last_lop_op = OP_METHOD;
3173 /* If followed by a bareword, see if it looks like indir obj. */
3175 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3178 /* Not a method, so call it a subroutine (if defined) */
3180 if (gv && GvCVu(gv)) {
3182 if (lastchar == '-')
3183 Perl_warn(aTHX_ "Ambiguous use of -%s resolved as -&%s()",
3184 PL_tokenbuf, PL_tokenbuf);
3185 /* Check for a constant sub */
3187 if ((sv = cv_const_sv(cv))) {
3189 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3190 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3191 yylval.opval->op_private = 0;
3195 /* Resolve to GV now. */
3196 op_free(yylval.opval);
3197 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3198 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3199 PL_last_lop = PL_oldbufptr;
3200 PL_last_lop_op = OP_ENTERSUB;
3201 /* Is there a prototype? */
3204 char *proto = SvPV((SV*)cv, len);
3207 if (strEQ(proto, "$"))
3209 if (*proto == '&' && *s == '{') {
3210 sv_setpv(PL_subname,"__ANON__");
3214 PL_nextval[PL_nexttoke].opval = yylval.opval;
3220 /* Call it a bare word */
3222 if (PL_hints & HINT_STRICT_SUBS)
3223 yylval.opval->op_private |= OPpCONST_STRICT;
3226 if (ckWARN(WARN_RESERVED)) {
3227 if (lastchar != '-') {
3228 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3230 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3237 if (lastchar && strchr("*%&", lastchar)) {
3238 Perl_warn(aTHX_ "Operator or semicolon missing before %c%s",
3239 lastchar, PL_tokenbuf);
3240 Perl_warn(aTHX_ "Ambiguous use of %c resolved as operator %c",
3241 lastchar, lastchar);
3247 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3248 newSVsv(GvSV(PL_curcop->cop_filegv)));
3252 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3253 Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3256 case KEY___PACKAGE__:
3257 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3259 ? newSVsv(PL_curstname)
3268 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3269 char *pname = "main";
3270 if (PL_tokenbuf[2] == 'D')
3271 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3272 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3275 GvIOp(gv) = newIO();
3276 IoIFP(GvIOp(gv)) = PL_rsfp;
3277 #if defined(HAS_FCNTL) && defined(F_SETFD)
3279 int fd = PerlIO_fileno(PL_rsfp);
3280 fcntl(fd,F_SETFD,fd >= 3);
3283 /* Mark this internal pseudo-handle as clean */
3284 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3286 IoTYPE(GvIOp(gv)) = '|';
3287 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3288 IoTYPE(GvIOp(gv)) = '-';
3290 IoTYPE(GvIOp(gv)) = '<';
3301 if (PL_expect == XSTATE) {
3308 if (*s == ':' && s[1] == ':') {
3311 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3312 tmp = keyword(PL_tokenbuf, len);
3326 LOP(OP_ACCEPT,XTERM);
3332 LOP(OP_ATAN2,XTERM);
3341 LOP(OP_BLESS,XTERM);
3350 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3367 if (!PL_cryptseen++)
3370 LOP(OP_CRYPT,XTERM);
3373 if (ckWARN(WARN_OCTAL)) {
3374 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3375 if (*d != '0' && isDIGIT(*d))
3376 yywarn("chmod: mode argument is missing initial 0");
3378 LOP(OP_CHMOD,XTERM);
3381 LOP(OP_CHOWN,XTERM);
3384 LOP(OP_CONNECT,XTERM);
3400 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3404 PL_hints |= HINT_BLOCK_SCOPE;
3414 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3415 LOP(OP_DBMOPEN,XTERM);
3421 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3428 yylval.ival = PL_curcop->cop_line;
3442 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3443 UNIBRACK(OP_ENTEREVAL);
3458 case KEY_endhostent:
3464 case KEY_endservent:
3467 case KEY_endprotoent:
3478 yylval.ival = PL_curcop->cop_line;
3480 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3482 if ((PL_bufend - p) >= 3 &&
3483 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3486 if (isIDFIRST_lazy(p))
3487 Perl_croak(aTHX_ "Missing $ on loop variable");
3492 LOP(OP_FORMLINE,XTERM);
3498 LOP(OP_FCNTL,XTERM);
3504 LOP(OP_FLOCK,XTERM);
3513 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3516 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3531 case KEY_getpriority:
3532 LOP(OP_GETPRIORITY,XTERM);
3534 case KEY_getprotobyname:
3537 case KEY_getprotobynumber:
3538 LOP(OP_GPBYNUMBER,XTERM);
3540 case KEY_getprotoent:
3552 case KEY_getpeername:
3553 UNI(OP_GETPEERNAME);
3555 case KEY_gethostbyname:
3558 case KEY_gethostbyaddr:
3559 LOP(OP_GHBYADDR,XTERM);
3561 case KEY_gethostent:
3564 case KEY_getnetbyname:
3567 case KEY_getnetbyaddr:
3568 LOP(OP_GNBYADDR,XTERM);
3573 case KEY_getservbyname:
3574 LOP(OP_GSBYNAME,XTERM);
3576 case KEY_getservbyport:
3577 LOP(OP_GSBYPORT,XTERM);
3579 case KEY_getservent:
3582 case KEY_getsockname:
3583 UNI(OP_GETSOCKNAME);
3585 case KEY_getsockopt:
3586 LOP(OP_GSOCKOPT,XTERM);
3608 yylval.ival = PL_curcop->cop_line;
3612 LOP(OP_INDEX,XTERM);
3618 LOP(OP_IOCTL,XTERM);
3630 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3661 LOP(OP_LISTEN,XTERM);
3670 s = scan_pat(s,OP_MATCH);
3671 TERM(sublex_start());
3674 LOP(OP_MAPSTART, XREF);
3677 LOP(OP_MKDIR,XTERM);
3680 LOP(OP_MSGCTL,XTERM);
3683 LOP(OP_MSGGET,XTERM);
3686 LOP(OP_MSGRCV,XTERM);
3689 LOP(OP_MSGSND,XTERM);
3694 if (isIDFIRST_lazy(s)) {
3695 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3696 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3697 if (!PL_in_my_stash) {
3700 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3707 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3714 if (PL_expect != XSTATE)
3715 yyerror("\"no\" not allowed in expression");
3716 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3717 s = force_version(s);
3726 if (isIDFIRST_lazy(s)) {
3728 for (d = s; isALNUM_lazy(d); d++) ;
3730 if (strchr("|&*+-=!?:.", *t))
3731 Perl_warn(aTHX_ "Precedence problem: open %.*s should be open(%.*s)",
3737 yylval.ival = OP_OR;
3747 LOP(OP_OPEN_DIR,XTERM);
3750 checkcomma(s,PL_tokenbuf,"filehandle");
3754 checkcomma(s,PL_tokenbuf,"filehandle");
3773 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3777 LOP(OP_PIPE_OP,XTERM);
3782 missingterm((char*)0);
3783 yylval.ival = OP_CONST;
3784 TERM(sublex_start());
3792 missingterm((char*)0);
3794 if (SvCUR(PL_lex_stuff)) {
3797 d = SvPV_force(PL_lex_stuff, len);
3799 for (; isSPACE(*d) && len; --len, ++d) ;
3802 if (!warned && ckWARN(WARN_SYNTAX)) {
3803 for (; !isSPACE(*d) && len; --len, ++d) {
3805 Perl_warner(aTHX_ WARN_SYNTAX,
3806 "Possible attempt to separate words with commas");
3809 else if (*d == '#') {
3810 Perl_warner(aTHX_ WARN_SYNTAX,
3811 "Possible attempt to put comments in qw() list");
3817 for (; !isSPACE(*d) && len; --len, ++d) ;
3819 words = append_elem(OP_LIST, words,
3820 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
3824 PL_nextval[PL_nexttoke].opval = words;
3829 SvREFCNT_dec(PL_lex_stuff);
3830 PL_lex_stuff = Nullsv;
3837 missingterm((char*)0);
3838 yylval.ival = OP_STRINGIFY;
3839 if (SvIVX(PL_lex_stuff) == '\'')
3840 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3841 TERM(sublex_start());
3844 s = scan_pat(s,OP_QR);
3845 TERM(sublex_start());
3850 missingterm((char*)0);
3851 yylval.ival = OP_BACKTICK;
3853 TERM(sublex_start());
3859 *PL_tokenbuf = '\0';
3860 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3861 if (isIDFIRST_lazy(PL_tokenbuf))
3862 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3864 yyerror("<> should be quotes");
3871 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3875 LOP(OP_RENAME,XTERM);
3884 LOP(OP_RINDEX,XTERM);
3907 LOP(OP_REVERSE,XTERM);
3918 TERM(sublex_start());
3920 TOKEN(1); /* force error */
3929 LOP(OP_SELECT,XTERM);
3935 LOP(OP_SEMCTL,XTERM);
3938 LOP(OP_SEMGET,XTERM);
3941 LOP(OP_SEMOP,XTERM);
3947 LOP(OP_SETPGRP,XTERM);
3949 case KEY_setpriority:
3950 LOP(OP_SETPRIORITY,XTERM);
3952 case KEY_sethostent:
3958 case KEY_setservent:
3961 case KEY_setprotoent:
3971 LOP(OP_SEEKDIR,XTERM);
3973 case KEY_setsockopt:
3974 LOP(OP_SSOCKOPT,XTERM);
3980 LOP(OP_SHMCTL,XTERM);
3983 LOP(OP_SHMGET,XTERM);
3986 LOP(OP_SHMREAD,XTERM);
3989 LOP(OP_SHMWRITE,XTERM);
3992 LOP(OP_SHUTDOWN,XTERM);
4001 LOP(OP_SOCKET,XTERM);
4003 case KEY_socketpair:
4004 LOP(OP_SOCKPAIR,XTERM);
4007 checkcomma(s,PL_tokenbuf,"subroutine name");
4009 if (*s == ';' || *s == ')') /* probably a close */
4010 Perl_croak(aTHX_ "sort is now a reserved word");
4012 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4016 LOP(OP_SPLIT,XTERM);
4019 LOP(OP_SPRINTF,XTERM);
4022 LOP(OP_SPLICE,XTERM);
4038 LOP(OP_SUBSTR,XTERM);
4045 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4046 char tmpbuf[sizeof PL_tokenbuf];
4048 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4049 if (strchr(tmpbuf, ':'))
4050 sv_setpv(PL_subname, tmpbuf);
4052 sv_setsv(PL_subname,PL_curstname);
4053 sv_catpvn(PL_subname,"::",2);
4054 sv_catpvn(PL_subname,tmpbuf,len);
4056 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4060 PL_expect = XTERMBLOCK;
4061 sv_setpv(PL_subname,"?");
4064 if (tmp == KEY_format) {
4067 PL_lex_formbrack = PL_lex_brackets + 1;
4071 /* Look for a prototype */
4078 SvREFCNT_dec(PL_lex_stuff);
4079 PL_lex_stuff = Nullsv;
4080 Perl_croak(aTHX_ "Prototype not terminated");
4083 d = SvPVX(PL_lex_stuff);
4085 for (p = d; *p; ++p) {
4090 SvCUR(PL_lex_stuff) = tmp;
4093 PL_nextval[1] = PL_nextval[0];
4094 PL_nexttype[1] = PL_nexttype[0];
4095 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4096 PL_nexttype[0] = THING;
4097 if (PL_nexttoke == 1) {
4098 PL_lex_defer = PL_lex_state;
4099 PL_lex_expect = PL_expect;
4100 PL_lex_state = LEX_KNOWNEXT;
4102 PL_lex_stuff = Nullsv;
4105 if (*SvPV(PL_subname,n_a) == '?') {
4106 sv_setpv(PL_subname,"__ANON__");
4113 LOP(OP_SYSTEM,XREF);
4116 LOP(OP_SYMLINK,XTERM);
4119 LOP(OP_SYSCALL,XTERM);
4122 LOP(OP_SYSOPEN,XTERM);
4125 LOP(OP_SYSSEEK,XTERM);
4128 LOP(OP_SYSREAD,XTERM);
4131 LOP(OP_SYSWRITE,XTERM);
4135 TERM(sublex_start());
4156 LOP(OP_TRUNCATE,XTERM);
4168 yylval.ival = PL_curcop->cop_line;
4172 yylval.ival = PL_curcop->cop_line;
4176 LOP(OP_UNLINK,XTERM);
4182 LOP(OP_UNPACK,XTERM);
4185 LOP(OP_UTIME,XTERM);
4188 if (ckWARN(WARN_OCTAL)) {
4189 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4190 if (*d != '0' && isDIGIT(*d))
4191 yywarn("umask: argument is missing initial 0");
4196 LOP(OP_UNSHIFT,XTERM);
4199 if (PL_expect != XSTATE)
4200 yyerror("\"use\" not allowed in expression");
4203 s = force_version(s);
4204 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4205 PL_nextval[PL_nexttoke].opval = Nullop;
4210 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4211 s = force_version(s);
4224 yylval.ival = PL_curcop->cop_line;
4228 PL_hints |= HINT_BLOCK_SCOPE;
4235 LOP(OP_WAITPID,XTERM);
4243 static char ctl_l[2];
4245 if (ctl_l[0] == '\0')
4246 ctl_l[0] = toCTRL('L');
4247 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4250 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4255 if (PL_expect == XOPERATOR)
4261 yylval.ival = OP_XOR;
4266 TERM(sublex_start());
4272 Perl_keyword(pTHX_ register char *d, I32 len)
4277 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4278 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4279 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4280 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4281 if (strEQ(d,"__END__")) return KEY___END__;
4285 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4290 if (strEQ(d,"and")) return -KEY_and;
4291 if (strEQ(d,"abs")) return -KEY_abs;
4294 if (strEQ(d,"alarm")) return -KEY_alarm;
4295 if (strEQ(d,"atan2")) return -KEY_atan2;
4298 if (strEQ(d,"accept")) return -KEY_accept;
4303 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4306 if (strEQ(d,"bless")) return -KEY_bless;
4307 if (strEQ(d,"bind")) return -KEY_bind;
4308 if (strEQ(d,"binmode")) return -KEY_binmode;
4311 if (strEQ(d,"CORE")) return -KEY_CORE;
4316 if (strEQ(d,"cmp")) return -KEY_cmp;
4317 if (strEQ(d,"chr")) return -KEY_chr;
4318 if (strEQ(d,"cos")) return -KEY_cos;
4321 if (strEQ(d,"chop")) return KEY_chop;
4324 if (strEQ(d,"close")) return -KEY_close;
4325 if (strEQ(d,"chdir")) return -KEY_chdir;
4326 if (strEQ(d,"chomp")) return KEY_chomp;
4327 if (strEQ(d,"chmod")) return -KEY_chmod;
4328 if (strEQ(d,"chown")) return -KEY_chown;
4329 if (strEQ(d,"crypt")) return -KEY_crypt;
4332 if (strEQ(d,"chroot")) return -KEY_chroot;
4333 if (strEQ(d,"caller")) return -KEY_caller;
4336 if (strEQ(d,"connect")) return -KEY_connect;
4339 if (strEQ(d,"closedir")) return -KEY_closedir;
4340 if (strEQ(d,"continue")) return -KEY_continue;
4345 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4350 if (strEQ(d,"do")) return KEY_do;
4353 if (strEQ(d,"die")) return -KEY_die;
4356 if (strEQ(d,"dump")) return -KEY_dump;
4359 if (strEQ(d,"delete")) return KEY_delete;
4362 if (strEQ(d,"defined")) return KEY_defined;
4363 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4366 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4371 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4372 if (strEQ(d,"END")) return KEY_END;
4377 if (strEQ(d,"eq")) return -KEY_eq;
4380 if (strEQ(d,"eof")) return -KEY_eof;
4381 if (strEQ(d,"exp")) return -KEY_exp;
4384 if (strEQ(d,"else")) return KEY_else;
4385 if (strEQ(d,"exit")) return -KEY_exit;
4386 if (strEQ(d,"eval")) return KEY_eval;
4387 if (strEQ(d,"exec")) return -KEY_exec;
4388 if (strEQ(d,"each")) return KEY_each;
4391 if (strEQ(d,"elsif")) return KEY_elsif;
4394 if (strEQ(d,"exists")) return KEY_exists;
4395 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4398 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4399 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4402 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4405 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4406 if (strEQ(d,"endservent")) return -KEY_endservent;
4409 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4416 if (strEQ(d,"for")) return KEY_for;
4419 if (strEQ(d,"fork")) return -KEY_fork;
4422 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4423 if (strEQ(d,"flock")) return -KEY_flock;
4426 if (strEQ(d,"format")) return KEY_format;
4427 if (strEQ(d,"fileno")) return -KEY_fileno;
4430 if (strEQ(d,"foreach")) return KEY_foreach;
4433 if (strEQ(d,"formline")) return -KEY_formline;
4439 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4440 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4444 if (strnEQ(d,"get",3)) {
4449 if (strEQ(d,"ppid")) return -KEY_getppid;
4450 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4453 if (strEQ(d,"pwent")) return -KEY_getpwent;
4454 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4455 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4458 if (strEQ(d,"peername")) return -KEY_getpeername;
4459 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4460 if (strEQ(d,"priority")) return -KEY_getpriority;
4463 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4466 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4470 else if (*d == 'h') {
4471 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4472 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4473 if (strEQ(d,"hostent")) return -KEY_gethostent;
4475 else if (*d == 'n') {
4476 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4477 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4478 if (strEQ(d,"netent")) return -KEY_getnetent;
4480 else if (*d == 's') {
4481 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4482 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4483 if (strEQ(d,"servent")) return -KEY_getservent;
4484 if (strEQ(d,"sockname")) return -KEY_getsockname;
4485 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4487 else if (*d == 'g') {
4488 if (strEQ(d,"grent")) return -KEY_getgrent;
4489 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4490 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4492 else if (*d == 'l') {
4493 if (strEQ(d,"login")) return -KEY_getlogin;
4495 else if (strEQ(d,"c")) return -KEY_getc;
4500 if (strEQ(d,"gt")) return -KEY_gt;
4501 if (strEQ(d,"ge")) return -KEY_ge;
4504 if (strEQ(d,"grep")) return KEY_grep;
4505 if (strEQ(d,"goto")) return KEY_goto;
4506 if (strEQ(d,"glob")) return KEY_glob;
4509 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4514 if (strEQ(d,"hex")) return -KEY_hex;
4517 if (strEQ(d,"INIT")) return KEY_INIT;
4522 if (strEQ(d,"if")) return KEY_if;
4525 if (strEQ(d,"int")) return -KEY_int;
4528 if (strEQ(d,"index")) return -KEY_index;
4529 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4534 if (strEQ(d,"join")) return -KEY_join;
4538 if (strEQ(d,"keys")) return KEY_keys;
4539 if (strEQ(d,"kill")) return -KEY_kill;
4544 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4545 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4551 if (strEQ(d,"lt")) return -KEY_lt;
4552 if (strEQ(d,"le")) return -KEY_le;
4553 if (strEQ(d,"lc")) return -KEY_lc;
4556 if (strEQ(d,"log")) return -KEY_log;
4559 if (strEQ(d,"last")) return KEY_last;
4560 if (strEQ(d,"link")) return -KEY_link;
4561 if (strEQ(d,"lock")) return -KEY_lock;
4564 if (strEQ(d,"local")) return KEY_local;
4565 if (strEQ(d,"lstat")) return -KEY_lstat;
4568 if (strEQ(d,"length")) return -KEY_length;
4569 if (strEQ(d,"listen")) return -KEY_listen;
4572 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4575 if (strEQ(d,"localtime")) return -KEY_localtime;
4581 case 1: return KEY_m;
4583 if (strEQ(d,"my")) return KEY_my;
4586 if (strEQ(d,"map")) return KEY_map;
4589 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4592 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4593 if (strEQ(d,"msgget")) return -KEY_msgget;
4594 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4595 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4600 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4603 if (strEQ(d,"next")) return KEY_next;
4604 if (strEQ(d,"ne")) return -KEY_ne;
4605 if (strEQ(d,"not")) return -KEY_not;
4606 if (strEQ(d,"no")) return KEY_no;
4611 if (strEQ(d,"or")) return -KEY_or;
4614 if (strEQ(d,"ord")) return -KEY_ord;
4615 if (strEQ(d,"oct")) return -KEY_oct;
4616 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4620 if (strEQ(d,"open")) return -KEY_open;
4623 if (strEQ(d,"opendir")) return -KEY_opendir;
4630 if (strEQ(d,"pop")) return KEY_pop;
4631 if (strEQ(d,"pos")) return KEY_pos;
4634 if (strEQ(d,"push")) return KEY_push;
4635 if (strEQ(d,"pack")) return -KEY_pack;
4636 if (strEQ(d,"pipe")) return -KEY_pipe;
4639 if (strEQ(d,"print")) return KEY_print;
4642 if (strEQ(d,"printf")) return KEY_printf;
4645 if (strEQ(d,"package")) return KEY_package;
4648 if (strEQ(d,"prototype")) return KEY_prototype;
4653 if (strEQ(d,"q")) return KEY_q;
4654 if (strEQ(d,"qr")) return KEY_qr;
4655 if (strEQ(d,"qq")) return KEY_qq;
4656 if (strEQ(d,"qw")) return KEY_qw;
4657 if (strEQ(d,"qx")) return KEY_qx;
4659 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4664 if (strEQ(d,"ref")) return -KEY_ref;
4667 if (strEQ(d,"read")) return -KEY_read;
4668 if (strEQ(d,"rand")) return -KEY_rand;
4669 if (strEQ(d,"recv")) return -KEY_recv;
4670 if (strEQ(d,"redo")) return KEY_redo;
4673 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4674 if (strEQ(d,"reset")) return -KEY_reset;
4677 if (strEQ(d,"return")) return KEY_return;
4678 if (strEQ(d,"rename")) return -KEY_rename;
4679 if (strEQ(d,"rindex")) return -KEY_rindex;
4682 if (strEQ(d,"require")) return -KEY_require;
4683 if (strEQ(d,"reverse")) return -KEY_reverse;
4684 if (strEQ(d,"readdir")) return -KEY_readdir;
4687 if (strEQ(d,"readlink")) return -KEY_readlink;
4688 if (strEQ(d,"readline")) return -KEY_readline;
4689 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4692 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4698 case 0: return KEY_s;
4700 if (strEQ(d,"scalar")) return KEY_scalar;
4705 if (strEQ(d,"seek")) return -KEY_seek;
4706 if (strEQ(d,"send")) return -KEY_send;
4709 if (strEQ(d,"semop")) return -KEY_semop;
4712 if (strEQ(d,"select")) return -KEY_select;
4713 if (strEQ(d,"semctl")) return -KEY_semctl;
4714 if (strEQ(d,"semget")) return -KEY_semget;
4717 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4718 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4721 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4722 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4725 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4728 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4729 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4730 if (strEQ(d,"setservent")) return -KEY_setservent;
4733 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4734 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4741 if (strEQ(d,"shift")) return KEY_shift;
4744 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4745 if (strEQ(d,"shmget")) return -KEY_shmget;
4748 if (strEQ(d,"shmread")) return -KEY_shmread;
4751 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4752 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4757 if (strEQ(d,"sin")) return -KEY_sin;
4760 if (strEQ(d,"sleep")) return -KEY_sleep;
4763 if (strEQ(d,"sort")) return KEY_sort;
4764 if (strEQ(d,"socket")) return -KEY_socket;
4765 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4768 if (strEQ(d,"split")) return KEY_split;
4769 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4770 if (strEQ(d,"splice")) return KEY_splice;
4773 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4776 if (strEQ(d,"srand")) return -KEY_srand;
4779 if (strEQ(d,"stat")) return -KEY_stat;
4780 if (strEQ(d,"study")) return KEY_study;
4783 if (strEQ(d,"substr")) return -KEY_substr;
4784 if (strEQ(d,"sub")) return KEY_sub;
4789 if (strEQ(d,"system")) return -KEY_system;
4792 if (strEQ(d,"symlink")) return -KEY_symlink;
4793 if (strEQ(d,"syscall")) return -KEY_syscall;
4794 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4795 if (strEQ(d,"sysread")) return -KEY_sysread;
4796 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4799 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4808 if (strEQ(d,"tr")) return KEY_tr;
4811 if (strEQ(d,"tie")) return KEY_tie;
4814 if (strEQ(d,"tell")) return -KEY_tell;
4815 if (strEQ(d,"tied")) return KEY_tied;
4816 if (strEQ(d,"time")) return -KEY_time;
4819 if (strEQ(d,"times")) return -KEY_times;
4822 if (strEQ(d,"telldir")) return -KEY_telldir;
4825 if (strEQ(d,"truncate")) return -KEY_truncate;
4832 if (strEQ(d,"uc")) return -KEY_uc;
4835 if (strEQ(d,"use")) return KEY_use;
4838 if (strEQ(d,"undef")) return KEY_undef;
4839 if (strEQ(d,"until")) return KEY_until;
4840 if (strEQ(d,"untie")) return KEY_untie;
4841 if (strEQ(d,"utime")) return -KEY_utime;
4842 if (strEQ(d,"umask")) return -KEY_umask;
4845 if (strEQ(d,"unless")) return KEY_unless;
4846 if (strEQ(d,"unpack")) return -KEY_unpack;
4847 if (strEQ(d,"unlink")) return -KEY_unlink;
4850 if (strEQ(d,"unshift")) return KEY_unshift;
4851 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4856 if (strEQ(d,"values")) return -KEY_values;
4857 if (strEQ(d,"vec")) return -KEY_vec;
4862 if (strEQ(d,"warn")) return -KEY_warn;
4863 if (strEQ(d,"wait")) return -KEY_wait;
4866 if (strEQ(d,"while")) return KEY_while;
4867 if (strEQ(d,"write")) return -KEY_write;
4870 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4873 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4878 if (len == 1) return -KEY_x;
4879 if (strEQ(d,"xor")) return -KEY_xor;
4882 if (len == 1) return KEY_y;
4891 S_checkcomma(pTHX_ register char *s, char *name, char *what)
4895 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4896 dTHR; /* only for ckWARN */
4897 if (ckWARN(WARN_SYNTAX)) {
4899 for (w = s+2; *w && level; w++) {
4906 for (; *w && isSPACE(*w); w++) ;
4907 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4908 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
4911 while (s < PL_bufend && isSPACE(*s))
4915 while (s < PL_bufend && isSPACE(*s))
4917 if (isIDFIRST_lazy(s)) {
4919 while (isALNUM_lazy(s))
4921 while (s < PL_bufend && isSPACE(*s))
4926 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
4930 Perl_croak(aTHX_ "No comma allowed after %s", what);
4936 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4939 HV *table = GvHV(PL_hintgv); /* ^H */
4942 bool oldcatch = CATCH_GET;
4947 yyerror("%^H is not defined");
4950 cvp = hv_fetch(table, key, strlen(key), FALSE);
4951 if (!cvp || !SvOK(*cvp)) {
4953 sprintf(buf,"$^H{%s} is not defined", key);
4957 sv_2mortal(sv); /* Parent created it permanently */
4960 pv = sv_2mortal(newSVpvn(s, len));
4962 typesv = sv_2mortal(newSVpv(type, 0));
4964 typesv = &PL_sv_undef;
4966 Zero(&myop, 1, BINOP);
4967 myop.op_last = (OP *) &myop;
4968 myop.op_next = Nullop;
4969 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4971 PUSHSTACKi(PERLSI_OVERLOAD);
4974 PL_op = (OP *) &myop;
4975 if (PERLDB_SUB && PL_curstash != PL_debstash)
4976 PL_op->op_private |= OPpENTERSUB_DB;
4978 Perl_pp_pushmark(aTHX);
4987 if (PL_op = Perl_pp_entersub(aTHX))
4994 CATCH_SET(oldcatch);
4999 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5002 return SvREFCNT_inc(res);
5006 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5008 register char *d = dest;
5009 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5012 Perl_croak(aTHX_ ident_too_long);
5013 if (isALNUM(*s)) /* UTF handled below */
5015 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5020 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5024 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5025 char *t = s + UTF8SKIP(s);
5026 while (*t & 0x80 && is_utf8_mark((U8*)t))
5028 if (d + (t - s) > e)
5029 Perl_croak(aTHX_ ident_too_long);
5030 Copy(s, d, t - s, char);
5043 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5050 if (PL_lex_brackets == 0)
5051 PL_lex_fakebrack = 0;
5055 e = d + destlen - 3; /* two-character token, ending NUL */
5057 while (isDIGIT(*s)) {
5059 Perl_croak(aTHX_ ident_too_long);
5066 Perl_croak(aTHX_ ident_too_long);
5067 if (isALNUM(*s)) /* UTF handled below */
5069 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5074 else if (*s == ':' && s[1] == ':') {
5078 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5079 char *t = s + UTF8SKIP(s);
5080 while (*t & 0x80 && is_utf8_mark((U8*)t))
5082 if (d + (t - s) > e)
5083 Perl_croak(aTHX_ ident_too_long);
5084 Copy(s, d, t - s, char);
5095 if (PL_lex_state != LEX_NORMAL)
5096 PL_lex_state = LEX_INTERPENDMAYBE;
5099 if (*s == '$' && s[1] &&
5100 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5113 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5118 if (isSPACE(s[-1])) {
5121 if (ch != ' ' && ch != '\t') {
5127 if (isIDFIRST_lazy(d)) {
5131 while (e < send && isALNUM_lazy(e) || *e == ':') {
5133 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5136 Copy(s, d, e - s, char);
5141 while ((isALNUM(*s) || *s == ':') && d < e)
5144 Perl_croak(aTHX_ ident_too_long);
5147 while (s < send && (*s == ' ' || *s == '\t')) s++;
5148 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5149 dTHR; /* only for ckWARN */
5150 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5151 char *brack = *s == '[' ? "[...]" : "{...}";
5152 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5153 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5154 funny, dest, brack, funny, dest, brack);
5156 PL_lex_fakebrack = PL_lex_brackets+1;
5158 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5162 /* Handle extended ${^Foo} variables
5163 * 1999-02-27 mjd-perl-patch@plover.com */
5164 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5168 while (isALNUM(*s) && d < e) {
5172 Perl_croak(aTHX_ ident_too_long);
5177 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5178 PL_lex_state = LEX_INTERPEND;
5181 if (PL_lex_state == LEX_NORMAL) {
5182 dTHR; /* only for ckWARN */
5183 if (ckWARN(WARN_AMBIGUOUS) &&
5184 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5186 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5187 "Ambiguous use of %c{%s} resolved to %c%s",
5188 funny, dest, funny, dest);
5193 s = bracket; /* let the parser handle it */
5197 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5198 PL_lex_state = LEX_INTERPEND;
5203 Perl_pmflag(pTHX_ 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 S_scan_pat(pTHX_ char *start, I32 type)
5227 s = scan_str(start);
5230 SvREFCNT_dec(PL_lex_stuff);
5231 PL_lex_stuff = Nullsv;
5232 Perl_croak(aTHX_ "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 S_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 Perl_croak(aTHX_ "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 Perl_croak(aTHX_ "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 S_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 Perl_croak(aTHX_ "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 Perl_croak(aTHX_ "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 Perl_croak(aTHX_ "Too many /C and /U options");
5396 o->op_private = del|squash|complement|utf8;
5399 yylval.ival = OP_TRANS;
5404 S_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 Perl_croak(aTHX_ "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 S_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 Perl_croak(aTHX_ "Excessively long <> operator");
5636 Perl_croak(aTHX_ "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 Perl_croak(aTHX_ "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 S_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 Perl_croak(aTHX_ "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(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6015 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6019 case '2': case '3': case '4':
6020 case '5': case '6': case '7':
6022 yyerror(Perl_form(aTHX_ "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 Perl_warn(aTHX_ "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 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6089 /* check for end of fixed-length buffer */
6091 Perl_croak(aTHX_ 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 Perl_warner(aTHX_ 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 Perl_croak(aTHX_ 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 Perl_croak(aTHX_ 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 S_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 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6372 else if (isPRINT_LC(yychar))
6373 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6375 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6376 where = SvPVX(where_sv);
6378 msg = sv_2mortal(newSVpv(s, 0));
6379 Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6380 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6382 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6384 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6385 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6386 Perl_sv_catpvf(aTHX_ msg,
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)
6392 Perl_warn(aTHX_ "%_", msg);
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 Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6400 PL_in_my_stash = Nullhv;