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 */
1152 *d++ = '\047'; /* CP 1047 */
1155 *d++ = '\057'; /* CP 1047 */
1169 } /* end if (backslash) */
1172 } /* while loop to process each character */
1174 /* terminate the string and set up the sv */
1176 SvCUR_set(sv, d - SvPVX(sv));
1179 /* shrink the sv if we allocated more than we used */
1180 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1181 SvLEN_set(sv, SvCUR(sv) + 1);
1182 Renew(SvPVX(sv), SvLEN(sv), char);
1185 /* return the substring (via yylval) only if we parsed anything */
1186 if (s > PL_bufptr) {
1187 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1188 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1190 ( PL_lex_inwhat == OP_TRANS
1192 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1195 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1201 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1203 S_intuit_more(pTHX_ register char *s)
1205 if (PL_lex_brackets)
1207 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1209 if (*s != '{' && *s != '[')
1214 /* In a pattern, so maybe we have {n,m}. */
1231 /* On the other hand, maybe we have a character class */
1234 if (*s == ']' || *s == '^')
1237 int weight = 2; /* let's weigh the evidence */
1239 unsigned char un_char = 255, last_un_char;
1240 char *send = strchr(s,']');
1241 char tmpbuf[sizeof PL_tokenbuf * 4];
1243 if (!send) /* has to be an expression */
1246 Zero(seen,256,char);
1249 else if (isDIGIT(*s)) {
1251 if (isDIGIT(s[1]) && s[2] == ']')
1257 for (; s < send; s++) {
1258 last_un_char = un_char;
1259 un_char = (unsigned char)*s;
1264 weight -= seen[un_char] * 10;
1265 if (isALNUM_lazy(s+1)) {
1266 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1267 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1272 else if (*s == '$' && s[1] &&
1273 strchr("[#!%*<>()-=",s[1])) {
1274 if (/*{*/ strchr("])} =",s[2]))
1283 if (strchr("wds]",s[1]))
1285 else if (seen['\''] || seen['"'])
1287 else if (strchr("rnftbxcav",s[1]))
1289 else if (isDIGIT(s[1])) {
1291 while (s[1] && isDIGIT(s[1]))
1301 if (strchr("aA01! ",last_un_char))
1303 if (strchr("zZ79~",s[1]))
1305 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1306 weight -= 5; /* cope with negative subscript */
1309 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1310 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1315 if (keyword(tmpbuf, d - tmpbuf))
1318 if (un_char == last_un_char + 1)
1320 weight -= seen[un_char];
1325 if (weight >= 0) /* probably a character class */
1333 S_intuit_method(pTHX_ char *start, GV *gv)
1335 char *s = start + (*start == '$');
1336 char tmpbuf[sizeof PL_tokenbuf];
1344 if ((cv = GvCVu(gv))) {
1345 char *proto = SvPVX(cv);
1355 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1356 if (*start == '$') {
1357 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1362 return *s == '(' ? FUNCMETH : METHOD;
1364 if (!keyword(tmpbuf, len)) {
1365 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1370 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1371 if (indirgv && GvCVu(indirgv))
1373 /* filehandle or package name makes it a method */
1374 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1376 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1377 return 0; /* no assumptions -- "=>" quotes bearword */
1379 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1380 newSVpvn(tmpbuf,len));
1381 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1385 return *s == '(' ? FUNCMETH : METHOD;
1395 char *pdb = PerlEnv_getenv("PERL5DB");
1399 SETERRNO(0,SS$_NORMAL);
1400 return "BEGIN { require 'perl5db.pl' }";
1406 /* Encoded script support. filter_add() effectively inserts a
1407 * 'pre-processing' function into the current source input stream.
1408 * Note that the filter function only applies to the current source file
1409 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1411 * The datasv parameter (which may be NULL) can be used to pass
1412 * private data to this instance of the filter. The filter function
1413 * can recover the SV using the FILTER_DATA macro and use it to
1414 * store private buffers and state information.
1416 * The supplied datasv parameter is upgraded to a PVIO type
1417 * and the IoDIRP field is used to store the function pointer.
1418 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1419 * private use must be set using malloc'd pointers.
1423 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1425 if (!funcp){ /* temporary handy debugging hack to be deleted */
1426 PL_filter_debug = atoi((char*)datasv);
1429 if (!PL_rsfp_filters)
1430 PL_rsfp_filters = newAV();
1432 datasv = NEWSV(255,0);
1433 if (!SvUPGRADE(datasv, SVt_PVIO))
1434 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1435 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1436 if (PL_filter_debug) {
1438 Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1440 av_unshift(PL_rsfp_filters, 1);
1441 av_store(PL_rsfp_filters, 0, datasv) ;
1446 /* Delete most recently added instance of this filter function. */
1448 Perl_filter_del(pTHX_ filter_t funcp)
1450 if (PL_filter_debug)
1451 Perl_warn(aTHX_ "filter_del func %p", funcp);
1452 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1454 /* if filter is on top of stack (usual case) just pop it off */
1455 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1456 IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1457 sv_free(av_pop(PL_rsfp_filters));
1461 /* we need to search for the correct entry and clear it */
1462 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1466 /* Invoke the n'th filter function for the current rsfp. */
1468 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1471 /* 0 = read one text line */
1476 if (!PL_rsfp_filters)
1478 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1479 /* Provide a default input filter to make life easy. */
1480 /* Note that we append to the line. This is handy. */
1481 if (PL_filter_debug)
1482 Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
1486 int old_len = SvCUR(buf_sv) ;
1488 /* ensure buf_sv is large enough */
1489 SvGROW(buf_sv, old_len + maxlen) ;
1490 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1491 if (PerlIO_error(PL_rsfp))
1492 return -1; /* error */
1494 return 0 ; /* end of file */
1496 SvCUR_set(buf_sv, old_len + len) ;
1499 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1500 if (PerlIO_error(PL_rsfp))
1501 return -1; /* error */
1503 return 0 ; /* end of file */
1506 return SvCUR(buf_sv);
1508 /* Skip this filter slot if filter has been deleted */
1509 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1510 if (PL_filter_debug)
1511 Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
1512 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1514 /* Get function pointer hidden within datasv */
1515 funcp = (filter_t)IoDIRP(datasv);
1516 if (PL_filter_debug) {
1518 Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
1519 idx, funcp, SvPV(datasv,n_a));
1521 /* Call function. The function is expected to */
1522 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1523 /* Return: <0:error, =0:eof, >0:not eof */
1524 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1528 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1531 if (!PL_rsfp_filters) {
1532 filter_add(win32_textfilter,NULL);
1535 if (PL_rsfp_filters) {
1538 SvCUR_set(sv, 0); /* start with empty line */
1539 if (FILTER_READ(0, sv, 0) > 0)
1540 return ( SvPVX(sv) ) ;
1545 return (sv_gets(sv, fp, append));
1550 static char* exp_name[] =
1551 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1557 Works out what to call the token just pulled out of the input
1558 stream. The yacc parser takes care of taking the ops we return and
1559 stitching them into a tree.
1565 if read an identifier
1566 if we're in a my declaration
1567 croak if they tried to say my($foo::bar)
1568 build the ops for a my() declaration
1569 if it's an access to a my() variable
1570 are we in a sort block?
1571 croak if my($a); $a <=> $b
1572 build ops for access to a my() variable
1573 if in a dq string, and they've said @foo and we can't find @foo
1575 build ops for a bareword
1576 if we already built the token before, use it.
1580 #ifdef USE_PURE_BISON
1581 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1594 #ifdef USE_PURE_BISON
1595 yylval_pointer = lvalp;
1596 yychar_pointer = lcharp;
1599 /* check if there's an identifier for us to look at */
1600 if (PL_pending_ident) {
1601 /* pit holds the identifier we read and pending_ident is reset */
1602 char pit = PL_pending_ident;
1603 PL_pending_ident = 0;
1605 /* if we're in a my(), we can't allow dynamics here.
1606 $foo'bar has already been turned into $foo::bar, so
1607 just check for colons.
1609 if it's a legal name, the OP is a PADANY.
1612 if (strchr(PL_tokenbuf,':'))
1613 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1615 yylval.opval = newOP(OP_PADANY, 0);
1616 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1621 build the ops for accesses to a my() variable.
1623 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1624 then used in a comparison. This catches most, but not
1625 all cases. For instance, it catches
1626 sort { my($a); $a <=> $b }
1628 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1629 (although why you'd do that is anyone's guess).
1632 if (!strchr(PL_tokenbuf,':')) {
1634 /* Check for single character per-thread SVs */
1635 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1636 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1637 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1639 yylval.opval = newOP(OP_THREADSV, 0);
1640 yylval.opval->op_targ = tmp;
1643 #endif /* USE_THREADS */
1644 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1645 /* if it's a sort block and they're naming $a or $b */
1646 if (PL_last_lop_op == OP_SORT &&
1647 PL_tokenbuf[0] == '$' &&
1648 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1651 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1652 d < PL_bufend && *d != '\n';
1655 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1656 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
1662 yylval.opval = newOP(OP_PADANY, 0);
1663 yylval.opval->op_targ = tmp;
1669 Whine if they've said @foo in a doublequoted string,
1670 and @foo isn't a variable we can find in the symbol
1673 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1674 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1675 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1676 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
1677 PL_tokenbuf, PL_tokenbuf));
1680 /* build ops for a bareword */
1681 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1682 yylval.opval->op_private = OPpCONST_ENTERED;
1683 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1684 ((PL_tokenbuf[0] == '$') ? SVt_PV
1685 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1690 /* no identifier pending identification */
1692 switch (PL_lex_state) {
1694 case LEX_NORMAL: /* Some compilers will produce faster */
1695 case LEX_INTERPNORMAL: /* code if we comment these out. */
1699 /* when we're already built the next token, just pull it out the queue */
1702 yylval = PL_nextval[PL_nexttoke];
1704 PL_lex_state = PL_lex_defer;
1705 PL_expect = PL_lex_expect;
1706 PL_lex_defer = LEX_NORMAL;
1708 return(PL_nexttype[PL_nexttoke]);
1710 /* interpolated case modifiers like \L \U, including \Q and \E.
1711 when we get here, PL_bufptr is at the \
1713 case LEX_INTERPCASEMOD:
1715 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1716 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
1718 /* handle \E or end of string */
1719 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1723 if (PL_lex_casemods) {
1724 oldmod = PL_lex_casestack[--PL_lex_casemods];
1725 PL_lex_casestack[PL_lex_casemods] = '\0';
1727 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1729 PL_lex_state = LEX_INTERPCONCAT;
1733 if (PL_bufptr != PL_bufend)
1735 PL_lex_state = LEX_INTERPCONCAT;
1740 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1741 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1742 if (strchr("LU", *s) &&
1743 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1745 PL_lex_casestack[--PL_lex_casemods] = '\0';
1748 if (PL_lex_casemods > 10) {
1749 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1750 if (newlb != PL_lex_casestack) {
1752 PL_lex_casestack = newlb;
1755 PL_lex_casestack[PL_lex_casemods++] = *s;
1756 PL_lex_casestack[PL_lex_casemods] = '\0';
1757 PL_lex_state = LEX_INTERPCONCAT;
1758 PL_nextval[PL_nexttoke].ival = 0;
1761 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1763 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1765 PL_nextval[PL_nexttoke].ival = OP_LC;
1767 PL_nextval[PL_nexttoke].ival = OP_UC;
1769 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1771 Perl_croak(aTHX_ "panic: yylex");
1774 if (PL_lex_starts) {
1783 case LEX_INTERPPUSH:
1784 return sublex_push();
1786 case LEX_INTERPSTART:
1787 if (PL_bufptr == PL_bufend)
1788 return sublex_done();
1790 PL_lex_dojoin = (*PL_bufptr == '@');
1791 PL_lex_state = LEX_INTERPNORMAL;
1792 if (PL_lex_dojoin) {
1793 PL_nextval[PL_nexttoke].ival = 0;
1796 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1797 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1798 force_next(PRIVATEREF);
1800 force_ident("\"", '$');
1801 #endif /* USE_THREADS */
1802 PL_nextval[PL_nexttoke].ival = 0;
1804 PL_nextval[PL_nexttoke].ival = 0;
1806 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1809 if (PL_lex_starts++) {
1815 case LEX_INTERPENDMAYBE:
1816 if (intuit_more(PL_bufptr)) {
1817 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1823 if (PL_lex_dojoin) {
1824 PL_lex_dojoin = FALSE;
1825 PL_lex_state = LEX_INTERPCONCAT;
1828 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
1829 && SvEVALED(PL_lex_repl))
1831 if (PL_bufptr != PL_bufend)
1832 Perl_croak(aTHX_ "Bad evalled substitution pattern");
1833 PL_lex_repl = Nullsv;
1836 case LEX_INTERPCONCAT:
1838 if (PL_lex_brackets)
1839 Perl_croak(aTHX_ "panic: INTERPCONCAT");
1841 if (PL_bufptr == PL_bufend)
1842 return sublex_done();
1844 if (SvIVX(PL_linestr) == '\'') {
1845 SV *sv = newSVsv(PL_linestr);
1848 else if ( PL_hints & HINT_NEW_RE )
1849 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1850 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1854 s = scan_const(PL_bufptr);
1856 PL_lex_state = LEX_INTERPCASEMOD;
1858 PL_lex_state = LEX_INTERPSTART;
1861 if (s != PL_bufptr) {
1862 PL_nextval[PL_nexttoke] = yylval;
1865 if (PL_lex_starts++)
1875 PL_lex_state = LEX_NORMAL;
1876 s = scan_formline(PL_bufptr);
1877 if (!PL_lex_formbrack)
1883 PL_oldoldbufptr = PL_oldbufptr;
1886 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1892 if (isIDFIRST_lazy(s))
1894 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
1897 goto fake_eof; /* emulate EOF on ^D or ^Z */
1902 if (PL_lex_brackets)
1903 yyerror("Missing right curly or square bracket");
1906 if (s++ < PL_bufend)
1907 goto retry; /* ignore stray nulls */
1910 if (!PL_in_eval && !PL_preambled) {
1911 PL_preambled = TRUE;
1912 sv_setpv(PL_linestr,incl_perldb());
1913 if (SvCUR(PL_linestr))
1914 sv_catpv(PL_linestr,";");
1916 while(AvFILLp(PL_preambleav) >= 0) {
1917 SV *tmpsv = av_shift(PL_preambleav);
1918 sv_catsv(PL_linestr, tmpsv);
1919 sv_catpv(PL_linestr, ";");
1922 sv_free((SV*)PL_preambleav);
1923 PL_preambleav = NULL;
1925 if (PL_minus_n || PL_minus_p) {
1926 sv_catpv(PL_linestr, "LINE: while (<>) {");
1928 sv_catpv(PL_linestr,"chomp;");
1930 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1932 GvIMPORTED_AV_on(gv);
1934 if (strchr("/'\"", *PL_splitstr)
1935 && strchr(PL_splitstr + 1, *PL_splitstr))
1936 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
1939 s = "'~#\200\1'"; /* surely one char is unused...*/
1940 while (s[1] && strchr(PL_splitstr, *s)) s++;
1942 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
1943 "q" + (delim == '\''), delim);
1944 for (s = PL_splitstr; *s; s++) {
1946 sv_catpvn(PL_linestr, "\\", 1);
1947 sv_catpvn(PL_linestr, s, 1);
1949 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
1953 sv_catpv(PL_linestr,"@F=split(' ');");
1956 sv_catpv(PL_linestr, "\n");
1957 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1958 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1959 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1960 SV *sv = NEWSV(85,0);
1962 sv_upgrade(sv, SVt_PVMG);
1963 sv_setsv(sv,PL_linestr);
1964 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1969 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1972 if (PL_preprocess && !PL_in_eval)
1973 (void)PerlProc_pclose(PL_rsfp);
1974 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1975 PerlIO_clearerr(PL_rsfp);
1977 (void)PerlIO_close(PL_rsfp);
1979 PL_doextract = FALSE;
1981 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1982 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1983 sv_catpv(PL_linestr,";}");
1984 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1985 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1986 PL_minus_n = PL_minus_p = 0;
1989 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1990 sv_setpv(PL_linestr,"");
1991 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1994 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1995 PL_doextract = FALSE;
1997 /* Incest with pod. */
1998 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1999 sv_setpv(PL_linestr, "");
2000 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2001 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2002 PL_doextract = FALSE;
2006 } while (PL_doextract);
2007 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2008 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2009 SV *sv = NEWSV(85,0);
2011 sv_upgrade(sv, SVt_PVMG);
2012 sv_setsv(sv,PL_linestr);
2013 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2015 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2016 if (PL_curcop->cop_line == 1) {
2017 while (s < PL_bufend && isSPACE(*s))
2019 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2023 if (*s == '#' && *(s+1) == '!')
2025 #ifdef ALTERNATE_SHEBANG
2027 static char as[] = ALTERNATE_SHEBANG;
2028 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2029 d = s + (sizeof(as) - 1);
2031 #endif /* ALTERNATE_SHEBANG */
2040 while (*d && !isSPACE(*d))
2044 #ifdef ARG_ZERO_IS_SCRIPT
2045 if (ipathend > ipath) {
2047 * HP-UX (at least) sets argv[0] to the script name,
2048 * which makes $^X incorrect. And Digital UNIX and Linux,
2049 * at least, set argv[0] to the basename of the Perl
2050 * interpreter. So, having found "#!", we'll set it right.
2052 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2053 assert(SvPOK(x) || SvGMAGICAL(x));
2054 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2055 sv_setpvn(x, ipath, ipathend - ipath);
2058 TAINT_NOT; /* $^X is always tainted, but that's OK */
2060 #endif /* ARG_ZERO_IS_SCRIPT */
2065 d = instr(s,"perl -");
2067 d = instr(s,"perl");
2068 #ifdef ALTERNATE_SHEBANG
2070 * If the ALTERNATE_SHEBANG on this system starts with a
2071 * character that can be part of a Perl expression, then if
2072 * we see it but not "perl", we're probably looking at the
2073 * start of Perl code, not a request to hand off to some
2074 * other interpreter. Similarly, if "perl" is there, but
2075 * not in the first 'word' of the line, we assume the line
2076 * contains the start of the Perl program.
2078 if (d && *s != '#') {
2080 while (*c && !strchr("; \t\r\n\f\v#", *c))
2083 d = Nullch; /* "perl" not in first word; ignore */
2085 *s = '#'; /* Don't try to parse shebang line */
2087 #endif /* ALTERNATE_SHEBANG */
2092 !instr(s,"indir") &&
2093 instr(PL_origargv[0],"perl"))
2099 while (s < PL_bufend && isSPACE(*s))
2101 if (s < PL_bufend) {
2102 Newz(899,newargv,PL_origargc+3,char*);
2104 while (s < PL_bufend && !isSPACE(*s))
2107 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2110 newargv = PL_origargv;
2112 PerlProc_execv(ipath, newargv);
2113 Perl_croak(aTHX_ "Can't exec %s", ipath);
2116 U32 oldpdb = PL_perldb;
2117 bool oldn = PL_minus_n;
2118 bool oldp = PL_minus_p;
2120 while (*d && !isSPACE(*d)) d++;
2121 while (*d == ' ' || *d == '\t') d++;
2125 if (*d == 'M' || *d == 'm') {
2127 while (*d && !isSPACE(*d)) d++;
2128 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2131 d = moreswitches(d);
2133 if (PERLDB_LINE && !oldpdb ||
2134 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2135 /* if we have already added "LINE: while (<>) {",
2136 we must not do it again */
2138 sv_setpv(PL_linestr, "");
2139 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2140 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2141 PL_preambled = FALSE;
2143 (void)gv_fetchfile(PL_origfilename);
2150 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2152 PL_lex_state = LEX_FORMLINE;
2157 #ifdef PERL_STRICT_CR
2158 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2160 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2162 case ' ': case '\t': case '\f': case 013:
2167 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2169 while (s < d && *s != '\n')
2174 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2176 PL_lex_state = LEX_FORMLINE;
2186 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2191 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2194 if (strnEQ(s,"=>",2)) {
2195 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2196 OPERATOR('-'); /* unary minus */
2198 PL_last_uni = PL_oldbufptr;
2199 PL_last_lop_op = OP_FTEREAD; /* good enough */
2201 case 'r': FTST(OP_FTEREAD);
2202 case 'w': FTST(OP_FTEWRITE);
2203 case 'x': FTST(OP_FTEEXEC);
2204 case 'o': FTST(OP_FTEOWNED);
2205 case 'R': FTST(OP_FTRREAD);
2206 case 'W': FTST(OP_FTRWRITE);
2207 case 'X': FTST(OP_FTREXEC);
2208 case 'O': FTST(OP_FTROWNED);
2209 case 'e': FTST(OP_FTIS);
2210 case 'z': FTST(OP_FTZERO);
2211 case 's': FTST(OP_FTSIZE);
2212 case 'f': FTST(OP_FTFILE);
2213 case 'd': FTST(OP_FTDIR);
2214 case 'l': FTST(OP_FTLINK);
2215 case 'p': FTST(OP_FTPIPE);
2216 case 'S': FTST(OP_FTSOCK);
2217 case 'u': FTST(OP_FTSUID);
2218 case 'g': FTST(OP_FTSGID);
2219 case 'k': FTST(OP_FTSVTX);
2220 case 'b': FTST(OP_FTBLK);
2221 case 'c': FTST(OP_FTCHR);
2222 case 't': FTST(OP_FTTTY);
2223 case 'T': FTST(OP_FTTEXT);
2224 case 'B': FTST(OP_FTBINARY);
2225 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2226 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2227 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2229 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2236 if (PL_expect == XOPERATOR)
2241 else if (*s == '>') {
2244 if (isIDFIRST_lazy(s)) {
2245 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2253 if (PL_expect == XOPERATOR)
2256 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2258 OPERATOR('-'); /* unary minus */
2265 if (PL_expect == XOPERATOR)
2270 if (PL_expect == XOPERATOR)
2273 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2279 if (PL_expect != XOPERATOR) {
2280 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2281 PL_expect = XOPERATOR;
2282 force_ident(PL_tokenbuf, '*');
2295 if (PL_expect == XOPERATOR) {
2299 PL_tokenbuf[0] = '%';
2300 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2301 if (!PL_tokenbuf[1]) {
2303 yyerror("Final % should be \\% or %name");
2306 PL_pending_ident = '%';
2328 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2329 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2334 if (PL_curcop->cop_line < PL_copline)
2335 PL_copline = PL_curcop->cop_line;
2346 if (PL_lex_brackets <= 0)
2347 yyerror("Unmatched right square bracket");
2350 if (PL_lex_state == LEX_INTERPNORMAL) {
2351 if (PL_lex_brackets == 0) {
2352 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2353 PL_lex_state = LEX_INTERPEND;
2360 if (PL_lex_brackets > 100) {
2361 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2362 if (newlb != PL_lex_brackstack) {
2364 PL_lex_brackstack = newlb;
2367 switch (PL_expect) {
2369 if (PL_lex_formbrack) {
2373 if (PL_oldoldbufptr == PL_last_lop)
2374 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2376 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2377 OPERATOR(HASHBRACK);
2379 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2382 PL_tokenbuf[0] = '\0';
2383 if (d < PL_bufend && *d == '-') {
2384 PL_tokenbuf[0] = '-';
2386 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2389 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2390 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2392 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2395 char minus = (PL_tokenbuf[0] == '-');
2396 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2403 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2407 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2412 if (PL_oldoldbufptr == PL_last_lop)
2413 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2415 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2418 OPERATOR(HASHBRACK);
2419 /* This hack serves to disambiguate a pair of curlies
2420 * as being a block or an anon hash. Normally, expectation
2421 * determines that, but in cases where we're not in a
2422 * position to expect anything in particular (like inside
2423 * eval"") we have to resolve the ambiguity. This code
2424 * covers the case where the first term in the curlies is a
2425 * quoted string. Most other cases need to be explicitly
2426 * disambiguated by prepending a `+' before the opening
2427 * curly in order to force resolution as an anon hash.
2429 * XXX should probably propagate the outer expectation
2430 * into eval"" to rely less on this hack, but that could
2431 * potentially break current behavior of eval"".
2435 if (*s == '\'' || *s == '"' || *s == '`') {
2436 /* common case: get past first string, handling escapes */
2437 for (t++; t < PL_bufend && *t != *s;)
2438 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2442 else if (*s == 'q') {
2445 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2446 && !isALNUM(*t)))) {
2448 char open, close, term;
2451 while (t < PL_bufend && isSPACE(*t))
2455 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2459 for (t++; t < PL_bufend; t++) {
2460 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2462 else if (*t == open)
2466 for (t++; t < PL_bufend; t++) {
2467 if (*t == '\\' && t+1 < PL_bufend)
2469 else if (*t == close && --brackets <= 0)
2471 else if (*t == open)
2477 else if (isIDFIRST_lazy(s)) {
2478 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2480 while (t < PL_bufend && isSPACE(*t))
2482 /* if comma follows first term, call it an anon hash */
2483 /* XXX it could be a comma expression with loop modifiers */
2484 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2485 || (*t == '=' && t[1] == '>')))
2486 OPERATOR(HASHBRACK);
2487 if (PL_expect == XREF)
2488 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2490 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2496 yylval.ival = PL_curcop->cop_line;
2497 if (isSPACE(*s) || *s == '#')
2498 PL_copline = NOLINE; /* invalidate current command line number */
2503 if (PL_lex_brackets <= 0)
2504 yyerror("Unmatched right curly bracket");
2506 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2507 if (PL_lex_brackets < PL_lex_formbrack)
2508 PL_lex_formbrack = 0;
2509 if (PL_lex_state == LEX_INTERPNORMAL) {
2510 if (PL_lex_brackets == 0) {
2511 if (PL_lex_fakebrack) {
2512 PL_lex_state = LEX_INTERPEND;
2514 return yylex(); /* ignore fake brackets */
2516 if (*s == '-' && s[1] == '>')
2517 PL_lex_state = LEX_INTERPENDMAYBE;
2518 else if (*s != '[' && *s != '{')
2519 PL_lex_state = LEX_INTERPEND;
2522 if (PL_lex_brackets < PL_lex_fakebrack) {
2524 PL_lex_fakebrack = 0;
2525 return yylex(); /* ignore fake brackets */
2535 if (PL_expect == XOPERATOR) {
2536 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2537 PL_curcop->cop_line--;
2538 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
2539 PL_curcop->cop_line++;
2544 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2546 PL_expect = XOPERATOR;
2547 force_ident(PL_tokenbuf, '&');
2551 yylval.ival = (OPpENTERSUB_AMPER<<8);
2570 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2571 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2573 if (PL_expect == XSTATE && isALPHA(tmp) &&
2574 (s == PL_linestart+1 || s[-2] == '\n') )
2576 if (PL_in_eval && !PL_rsfp) {
2581 if (strnEQ(s,"=cut",4)) {
2595 PL_doextract = TRUE;
2598 if (PL_lex_brackets < PL_lex_formbrack) {
2600 #ifdef PERL_STRICT_CR
2601 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2603 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2605 if (*t == '\n' || *t == '#') {
2623 if (PL_expect != XOPERATOR) {
2624 if (s[1] != '<' && !strchr(s,'>'))
2627 s = scan_heredoc(s);
2629 s = scan_inputsymbol(s);
2630 TERM(sublex_start());
2635 SHop(OP_LEFT_SHIFT);
2649 SHop(OP_RIGHT_SHIFT);
2658 if (PL_expect == XOPERATOR) {
2659 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2662 return ','; /* grandfather non-comma-format format */
2666 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2667 if (PL_expect == XOPERATOR)
2668 no_op("Array length", PL_bufptr);
2669 PL_tokenbuf[0] = '@';
2670 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2672 if (!PL_tokenbuf[1])
2674 PL_expect = XOPERATOR;
2675 PL_pending_ident = '#';
2679 if (PL_expect == XOPERATOR)
2680 no_op("Scalar", PL_bufptr);
2681 PL_tokenbuf[0] = '$';
2682 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2683 if (!PL_tokenbuf[1]) {
2685 yyerror("Final $ should be \\$ or $name");
2689 /* This kludge not intended to be bulletproof. */
2690 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2691 yylval.opval = newSVOP(OP_CONST, 0,
2692 newSViv((IV)PL_compiling.cop_arybase));
2693 yylval.opval->op_private = OPpCONST_ARYBASE;
2699 if (PL_lex_state == LEX_NORMAL)
2702 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2705 PL_tokenbuf[0] = '@';
2706 if (ckWARN(WARN_SYNTAX)) {
2708 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2711 PL_bufptr = skipspace(PL_bufptr);
2712 while (t < PL_bufend && *t != ']')
2714 Perl_warner(aTHX_ WARN_SYNTAX,
2715 "Multidimensional syntax %.*s not supported",
2716 (t - PL_bufptr) + 1, PL_bufptr);
2720 else if (*s == '{') {
2721 PL_tokenbuf[0] = '%';
2722 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2723 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2725 char tmpbuf[sizeof PL_tokenbuf];
2727 for (t++; isSPACE(*t); t++) ;
2728 if (isIDFIRST_lazy(t)) {
2729 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2730 for (; isSPACE(*t); t++) ;
2731 if (*t == ';' && get_cv(tmpbuf, FALSE))
2732 Perl_warner(aTHX_ WARN_SYNTAX,
2733 "You need to quote \"%s\"", tmpbuf);
2739 PL_expect = XOPERATOR;
2740 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
2741 bool islop = (PL_last_lop == PL_oldoldbufptr);
2742 if (!islop || PL_last_lop_op == OP_GREPSTART)
2743 PL_expect = XOPERATOR;
2744 else if (strchr("$@\"'`q", *s))
2745 PL_expect = XTERM; /* e.g. print $fh "foo" */
2746 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2747 PL_expect = XTERM; /* e.g. print $fh &sub */
2748 else if (isIDFIRST_lazy(s)) {
2749 char tmpbuf[sizeof PL_tokenbuf];
2750 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2751 if (tmp = keyword(tmpbuf, len)) {
2752 /* binary operators exclude handle interpretations */
2764 PL_expect = XTERM; /* e.g. print $fh length() */
2769 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2770 if (gv && GvCVu(gv))
2771 PL_expect = XTERM; /* e.g. print $fh subr() */
2774 else if (isDIGIT(*s))
2775 PL_expect = XTERM; /* e.g. print $fh 3 */
2776 else if (*s == '.' && isDIGIT(s[1]))
2777 PL_expect = XTERM; /* e.g. print $fh .3 */
2778 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2779 PL_expect = XTERM; /* e.g. print $fh -1 */
2780 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2781 PL_expect = XTERM; /* print $fh <<"EOF" */
2783 PL_pending_ident = '$';
2787 if (PL_expect == XOPERATOR)
2789 PL_tokenbuf[0] = '@';
2790 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2791 if (!PL_tokenbuf[1]) {
2793 yyerror("Final @ should be \\@ or @name");
2796 if (PL_lex_state == LEX_NORMAL)
2798 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2800 PL_tokenbuf[0] = '%';
2802 /* Warn about @ where they meant $. */
2803 if (ckWARN(WARN_SYNTAX)) {
2804 if (*s == '[' || *s == '{') {
2806 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2808 if (*t == '}' || *t == ']') {
2810 PL_bufptr = skipspace(PL_bufptr);
2811 Perl_warner(aTHX_ WARN_SYNTAX,
2812 "Scalar value %.*s better written as $%.*s",
2813 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2818 PL_pending_ident = '@';
2821 case '/': /* may either be division or pattern */
2822 case '?': /* may either be conditional or pattern */
2823 if (PL_expect != XOPERATOR) {
2824 /* Disable warning on "study /blah/" */
2825 if (PL_oldoldbufptr == PL_last_uni
2826 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2827 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2829 s = scan_pat(s,OP_MATCH);
2830 TERM(sublex_start());
2838 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2839 #ifdef PERL_STRICT_CR
2842 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2844 && (s == PL_linestart || s[-1] == '\n') )
2846 PL_lex_formbrack = 0;
2850 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2856 yylval.ival = OPf_SPECIAL;
2862 if (PL_expect != XOPERATOR)
2867 case '0': case '1': case '2': case '3': case '4':
2868 case '5': case '6': case '7': case '8': case '9':
2870 if (PL_expect == XOPERATOR)
2876 if (PL_expect == XOPERATOR) {
2877 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2880 return ','; /* grandfather non-comma-format format */
2886 missingterm((char*)0);
2887 yylval.ival = OP_CONST;
2888 TERM(sublex_start());
2892 if (PL_expect == XOPERATOR) {
2893 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2896 return ','; /* grandfather non-comma-format format */
2902 missingterm((char*)0);
2903 yylval.ival = OP_CONST;
2904 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2905 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2906 yylval.ival = OP_STRINGIFY;
2910 TERM(sublex_start());
2914 if (PL_expect == XOPERATOR)
2915 no_op("Backticks",s);
2917 missingterm((char*)0);
2918 yylval.ival = OP_BACKTICK;
2920 TERM(sublex_start());
2924 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2925 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2927 if (PL_expect == XOPERATOR)
2928 no_op("Backslash",s);
2932 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2972 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2974 /* Some keywords can be followed by any delimiter, including ':' */
2975 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2976 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2977 (PL_tokenbuf[0] == 'q' &&
2978 strchr("qwxr", PL_tokenbuf[1]))));
2980 /* x::* is just a word, unless x is "CORE" */
2981 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2985 while (d < PL_bufend && isSPACE(*d))
2986 d++; /* no comments skipped here, or s### is misparsed */
2988 /* Is this a label? */
2989 if (!tmp && PL_expect == XSTATE
2990 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2992 yylval.pval = savepv(PL_tokenbuf);
2997 /* Check for keywords */
2998 tmp = keyword(PL_tokenbuf, len);
3000 /* Is this a word before a => operator? */
3001 if (strnEQ(d,"=>",2)) {
3003 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3004 yylval.opval->op_private = OPpCONST_BARE;
3008 if (tmp < 0) { /* second-class keyword? */
3009 GV *ogv = Nullgv; /* override (winner) */
3010 GV *hgv = Nullgv; /* hidden (loser) */
3011 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3013 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3016 if (GvIMPORTED_CV(gv))
3018 else if (! CvMETHOD(cv))
3022 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3023 (gv = *gvp) != (GV*)&PL_sv_undef &&
3024 GvCVu(gv) && GvIMPORTED_CV(gv))
3030 tmp = 0; /* overridden by import or by GLOBAL */
3033 && -tmp==KEY_lock /* XXX generalizable kludge */
3034 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3036 tmp = 0; /* any sub overrides "weak" keyword */
3038 else { /* no override */
3042 if (ckWARN(WARN_AMBIGUOUS) && hgv
3043 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3044 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3045 "Ambiguous call resolved as CORE::%s(), %s",
3046 GvENAME(hgv), "qualify as such or use &");
3053 default: /* not a keyword */
3056 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3058 /* Get the rest if it looks like a package qualifier */
3060 if (*s == '\'' || *s == ':' && s[1] == ':') {
3062 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3065 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3066 *s == '\'' ? "'" : "::");
3070 if (PL_expect == XOPERATOR) {
3071 if (PL_bufptr == PL_linestart) {
3072 PL_curcop->cop_line--;
3073 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3074 PL_curcop->cop_line++;
3077 no_op("Bareword",s);
3080 /* Look for a subroutine with this name in current package,
3081 unless name is "Foo::", in which case Foo is a bearword
3082 (and a package name). */
3085 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3087 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3088 Perl_warner(aTHX_ WARN_UNSAFE,
3089 "Bareword \"%s\" refers to nonexistent package",
3092 PL_tokenbuf[len] = '\0';
3099 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3102 /* if we saw a global override before, get the right name */
3105 sv = newSVpvn("CORE::GLOBAL::",14);
3106 sv_catpv(sv,PL_tokenbuf);
3109 sv = newSVpv(PL_tokenbuf,0);
3111 /* Presume this is going to be a bareword of some sort. */
3114 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3115 yylval.opval->op_private = OPpCONST_BARE;
3117 /* And if "Foo::", then that's what it certainly is. */
3122 /* See if it's the indirect object for a list operator. */
3124 if (PL_oldoldbufptr &&
3125 PL_oldoldbufptr < PL_bufptr &&
3126 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3127 /* NO SKIPSPACE BEFORE HERE! */
3128 (PL_expect == XREF ||
3129 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3131 bool immediate_paren = *s == '(';
3133 /* (Now we can afford to cross potential line boundary.) */
3136 /* Two barewords in a row may indicate method call. */
3138 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3141 /* If not a declared subroutine, it's an indirect object. */
3142 /* (But it's an indir obj regardless for sort.) */
3144 if ((PL_last_lop_op == OP_SORT ||
3145 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3146 (PL_last_lop_op != OP_MAPSTART &&
3147 PL_last_lop_op != OP_GREPSTART))
3149 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3154 /* If followed by a paren, it's certainly a subroutine. */
3156 PL_expect = XOPERATOR;
3160 if (gv && GvCVu(gv)) {
3161 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3162 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3167 PL_nextval[PL_nexttoke].opval = yylval.opval;
3168 PL_expect = XOPERATOR;
3174 /* If followed by var or block, call it a method (unless sub) */
3176 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3177 PL_last_lop = PL_oldbufptr;
3178 PL_last_lop_op = OP_METHOD;
3182 /* If followed by a bareword, see if it looks like indir obj. */
3184 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3187 /* Not a method, so call it a subroutine (if defined) */
3189 if (gv && GvCVu(gv)) {
3191 if (lastchar == '-')
3192 Perl_warn(aTHX_ "Ambiguous use of -%s resolved as -&%s()",
3193 PL_tokenbuf, PL_tokenbuf);
3194 /* Check for a constant sub */
3196 if ((sv = cv_const_sv(cv))) {
3198 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3199 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3200 yylval.opval->op_private = 0;
3204 /* Resolve to GV now. */
3205 op_free(yylval.opval);
3206 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3207 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3208 PL_last_lop = PL_oldbufptr;
3209 PL_last_lop_op = OP_ENTERSUB;
3210 /* Is there a prototype? */
3213 char *proto = SvPV((SV*)cv, len);
3216 if (strEQ(proto, "$"))
3218 if (*proto == '&' && *s == '{') {
3219 sv_setpv(PL_subname,"__ANON__");
3223 PL_nextval[PL_nexttoke].opval = yylval.opval;
3229 /* Call it a bare word */
3231 if (PL_hints & HINT_STRICT_SUBS)
3232 yylval.opval->op_private |= OPpCONST_STRICT;
3235 if (ckWARN(WARN_RESERVED)) {
3236 if (lastchar != '-') {
3237 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3239 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3246 if (lastchar && strchr("*%&", lastchar)) {
3247 Perl_warn(aTHX_ "Operator or semicolon missing before %c%s",
3248 lastchar, PL_tokenbuf);
3249 Perl_warn(aTHX_ "Ambiguous use of %c resolved as operator %c",
3250 lastchar, lastchar);
3256 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3257 newSVsv(GvSV(PL_curcop->cop_filegv)));
3261 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3262 Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3265 case KEY___PACKAGE__:
3266 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3268 ? newSVsv(PL_curstname)
3277 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3278 char *pname = "main";
3279 if (PL_tokenbuf[2] == 'D')
3280 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3281 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3284 GvIOp(gv) = newIO();
3285 IoIFP(GvIOp(gv)) = PL_rsfp;
3286 #if defined(HAS_FCNTL) && defined(F_SETFD)
3288 int fd = PerlIO_fileno(PL_rsfp);
3289 fcntl(fd,F_SETFD,fd >= 3);
3292 /* Mark this internal pseudo-handle as clean */
3293 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3295 IoTYPE(GvIOp(gv)) = '|';
3296 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3297 IoTYPE(GvIOp(gv)) = '-';
3299 IoTYPE(GvIOp(gv)) = '<';
3310 if (PL_expect == XSTATE) {
3317 if (*s == ':' && s[1] == ':') {
3320 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3321 tmp = keyword(PL_tokenbuf, len);
3335 LOP(OP_ACCEPT,XTERM);
3341 LOP(OP_ATAN2,XTERM);
3350 LOP(OP_BLESS,XTERM);
3359 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3376 if (!PL_cryptseen++)
3379 LOP(OP_CRYPT,XTERM);
3382 if (ckWARN(WARN_OCTAL)) {
3383 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3384 if (*d != '0' && isDIGIT(*d))
3385 yywarn("chmod: mode argument is missing initial 0");
3387 LOP(OP_CHMOD,XTERM);
3390 LOP(OP_CHOWN,XTERM);
3393 LOP(OP_CONNECT,XTERM);
3409 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3413 PL_hints |= HINT_BLOCK_SCOPE;
3423 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3424 LOP(OP_DBMOPEN,XTERM);
3430 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3437 yylval.ival = PL_curcop->cop_line;
3451 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3452 UNIBRACK(OP_ENTEREVAL);
3467 case KEY_endhostent:
3473 case KEY_endservent:
3476 case KEY_endprotoent:
3487 yylval.ival = PL_curcop->cop_line;
3489 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3491 if ((PL_bufend - p) >= 3 &&
3492 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3495 if (isIDFIRST_lazy(p))
3496 Perl_croak(aTHX_ "Missing $ on loop variable");
3501 LOP(OP_FORMLINE,XTERM);
3507 LOP(OP_FCNTL,XTERM);
3513 LOP(OP_FLOCK,XTERM);
3522 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3525 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3540 case KEY_getpriority:
3541 LOP(OP_GETPRIORITY,XTERM);
3543 case KEY_getprotobyname:
3546 case KEY_getprotobynumber:
3547 LOP(OP_GPBYNUMBER,XTERM);
3549 case KEY_getprotoent:
3561 case KEY_getpeername:
3562 UNI(OP_GETPEERNAME);
3564 case KEY_gethostbyname:
3567 case KEY_gethostbyaddr:
3568 LOP(OP_GHBYADDR,XTERM);
3570 case KEY_gethostent:
3573 case KEY_getnetbyname:
3576 case KEY_getnetbyaddr:
3577 LOP(OP_GNBYADDR,XTERM);
3582 case KEY_getservbyname:
3583 LOP(OP_GSBYNAME,XTERM);
3585 case KEY_getservbyport:
3586 LOP(OP_GSBYPORT,XTERM);
3588 case KEY_getservent:
3591 case KEY_getsockname:
3592 UNI(OP_GETSOCKNAME);
3594 case KEY_getsockopt:
3595 LOP(OP_GSOCKOPT,XTERM);
3617 yylval.ival = PL_curcop->cop_line;
3621 LOP(OP_INDEX,XTERM);
3627 LOP(OP_IOCTL,XTERM);
3639 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3670 LOP(OP_LISTEN,XTERM);
3679 s = scan_pat(s,OP_MATCH);
3680 TERM(sublex_start());
3683 LOP(OP_MAPSTART, XREF);
3686 LOP(OP_MKDIR,XTERM);
3689 LOP(OP_MSGCTL,XTERM);
3692 LOP(OP_MSGGET,XTERM);
3695 LOP(OP_MSGRCV,XTERM);
3698 LOP(OP_MSGSND,XTERM);
3703 if (isIDFIRST_lazy(s)) {
3704 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3705 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3706 if (!PL_in_my_stash) {
3709 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3716 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3723 if (PL_expect != XSTATE)
3724 yyerror("\"no\" not allowed in expression");
3725 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3726 s = force_version(s);
3735 if (isIDFIRST_lazy(s)) {
3737 for (d = s; isALNUM_lazy(d); d++) ;
3739 if (strchr("|&*+-=!?:.", *t))
3740 Perl_warn(aTHX_ "Precedence problem: open %.*s should be open(%.*s)",
3746 yylval.ival = OP_OR;
3756 LOP(OP_OPEN_DIR,XTERM);
3759 checkcomma(s,PL_tokenbuf,"filehandle");
3763 checkcomma(s,PL_tokenbuf,"filehandle");
3782 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3786 LOP(OP_PIPE_OP,XTERM);
3791 missingterm((char*)0);
3792 yylval.ival = OP_CONST;
3793 TERM(sublex_start());
3801 missingterm((char*)0);
3803 if (SvCUR(PL_lex_stuff)) {
3806 d = SvPV_force(PL_lex_stuff, len);
3808 for (; isSPACE(*d) && len; --len, ++d) ;
3811 if (!warned && ckWARN(WARN_SYNTAX)) {
3812 for (; !isSPACE(*d) && len; --len, ++d) {
3814 Perl_warner(aTHX_ WARN_SYNTAX,
3815 "Possible attempt to separate words with commas");
3818 else if (*d == '#') {
3819 Perl_warner(aTHX_ WARN_SYNTAX,
3820 "Possible attempt to put comments in qw() list");
3826 for (; !isSPACE(*d) && len; --len, ++d) ;
3828 words = append_elem(OP_LIST, words,
3829 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
3833 PL_nextval[PL_nexttoke].opval = words;
3838 SvREFCNT_dec(PL_lex_stuff);
3839 PL_lex_stuff = Nullsv;
3846 missingterm((char*)0);
3847 yylval.ival = OP_STRINGIFY;
3848 if (SvIVX(PL_lex_stuff) == '\'')
3849 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3850 TERM(sublex_start());
3853 s = scan_pat(s,OP_QR);
3854 TERM(sublex_start());
3859 missingterm((char*)0);
3860 yylval.ival = OP_BACKTICK;
3862 TERM(sublex_start());
3868 *PL_tokenbuf = '\0';
3869 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3870 if (isIDFIRST_lazy(PL_tokenbuf))
3871 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3873 yyerror("<> should be quotes");
3880 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3884 LOP(OP_RENAME,XTERM);
3893 LOP(OP_RINDEX,XTERM);
3916 LOP(OP_REVERSE,XTERM);
3927 TERM(sublex_start());
3929 TOKEN(1); /* force error */
3938 LOP(OP_SELECT,XTERM);
3944 LOP(OP_SEMCTL,XTERM);
3947 LOP(OP_SEMGET,XTERM);
3950 LOP(OP_SEMOP,XTERM);
3956 LOP(OP_SETPGRP,XTERM);
3958 case KEY_setpriority:
3959 LOP(OP_SETPRIORITY,XTERM);
3961 case KEY_sethostent:
3967 case KEY_setservent:
3970 case KEY_setprotoent:
3980 LOP(OP_SEEKDIR,XTERM);
3982 case KEY_setsockopt:
3983 LOP(OP_SSOCKOPT,XTERM);
3989 LOP(OP_SHMCTL,XTERM);
3992 LOP(OP_SHMGET,XTERM);
3995 LOP(OP_SHMREAD,XTERM);
3998 LOP(OP_SHMWRITE,XTERM);
4001 LOP(OP_SHUTDOWN,XTERM);
4010 LOP(OP_SOCKET,XTERM);
4012 case KEY_socketpair:
4013 LOP(OP_SOCKPAIR,XTERM);
4016 checkcomma(s,PL_tokenbuf,"subroutine name");
4018 if (*s == ';' || *s == ')') /* probably a close */
4019 Perl_croak(aTHX_ "sort is now a reserved word");
4021 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4025 LOP(OP_SPLIT,XTERM);
4028 LOP(OP_SPRINTF,XTERM);
4031 LOP(OP_SPLICE,XTERM);
4047 LOP(OP_SUBSTR,XTERM);
4054 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4055 char tmpbuf[sizeof PL_tokenbuf];
4057 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4058 if (strchr(tmpbuf, ':'))
4059 sv_setpv(PL_subname, tmpbuf);
4061 sv_setsv(PL_subname,PL_curstname);
4062 sv_catpvn(PL_subname,"::",2);
4063 sv_catpvn(PL_subname,tmpbuf,len);
4065 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4069 PL_expect = XTERMBLOCK;
4070 sv_setpv(PL_subname,"?");
4073 if (tmp == KEY_format) {
4076 PL_lex_formbrack = PL_lex_brackets + 1;
4080 /* Look for a prototype */
4087 SvREFCNT_dec(PL_lex_stuff);
4088 PL_lex_stuff = Nullsv;
4089 Perl_croak(aTHX_ "Prototype not terminated");
4092 d = SvPVX(PL_lex_stuff);
4094 for (p = d; *p; ++p) {
4099 SvCUR(PL_lex_stuff) = tmp;
4102 PL_nextval[1] = PL_nextval[0];
4103 PL_nexttype[1] = PL_nexttype[0];
4104 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4105 PL_nexttype[0] = THING;
4106 if (PL_nexttoke == 1) {
4107 PL_lex_defer = PL_lex_state;
4108 PL_lex_expect = PL_expect;
4109 PL_lex_state = LEX_KNOWNEXT;
4111 PL_lex_stuff = Nullsv;
4114 if (*SvPV(PL_subname,n_a) == '?') {
4115 sv_setpv(PL_subname,"__ANON__");
4122 LOP(OP_SYSTEM,XREF);
4125 LOP(OP_SYMLINK,XTERM);
4128 LOP(OP_SYSCALL,XTERM);
4131 LOP(OP_SYSOPEN,XTERM);
4134 LOP(OP_SYSSEEK,XTERM);
4137 LOP(OP_SYSREAD,XTERM);
4140 LOP(OP_SYSWRITE,XTERM);
4144 TERM(sublex_start());
4165 LOP(OP_TRUNCATE,XTERM);
4177 yylval.ival = PL_curcop->cop_line;
4181 yylval.ival = PL_curcop->cop_line;
4185 LOP(OP_UNLINK,XTERM);
4191 LOP(OP_UNPACK,XTERM);
4194 LOP(OP_UTIME,XTERM);
4197 if (ckWARN(WARN_OCTAL)) {
4198 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4199 if (*d != '0' && isDIGIT(*d))
4200 yywarn("umask: argument is missing initial 0");
4205 LOP(OP_UNSHIFT,XTERM);
4208 if (PL_expect != XSTATE)
4209 yyerror("\"use\" not allowed in expression");
4212 s = force_version(s);
4213 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4214 PL_nextval[PL_nexttoke].opval = Nullop;
4219 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4220 s = force_version(s);
4233 yylval.ival = PL_curcop->cop_line;
4237 PL_hints |= HINT_BLOCK_SCOPE;
4244 LOP(OP_WAITPID,XTERM);
4252 static char ctl_l[2];
4254 if (ctl_l[0] == '\0')
4255 ctl_l[0] = toCTRL('L');
4256 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4259 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4264 if (PL_expect == XOPERATOR)
4270 yylval.ival = OP_XOR;
4275 TERM(sublex_start());
4281 Perl_keyword(pTHX_ register char *d, I32 len)
4286 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4287 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4288 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4289 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4290 if (strEQ(d,"__END__")) return KEY___END__;
4294 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4299 if (strEQ(d,"and")) return -KEY_and;
4300 if (strEQ(d,"abs")) return -KEY_abs;
4303 if (strEQ(d,"alarm")) return -KEY_alarm;
4304 if (strEQ(d,"atan2")) return -KEY_atan2;
4307 if (strEQ(d,"accept")) return -KEY_accept;
4312 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4315 if (strEQ(d,"bless")) return -KEY_bless;
4316 if (strEQ(d,"bind")) return -KEY_bind;
4317 if (strEQ(d,"binmode")) return -KEY_binmode;
4320 if (strEQ(d,"CORE")) return -KEY_CORE;
4325 if (strEQ(d,"cmp")) return -KEY_cmp;
4326 if (strEQ(d,"chr")) return -KEY_chr;
4327 if (strEQ(d,"cos")) return -KEY_cos;
4330 if (strEQ(d,"chop")) return KEY_chop;
4333 if (strEQ(d,"close")) return -KEY_close;
4334 if (strEQ(d,"chdir")) return -KEY_chdir;
4335 if (strEQ(d,"chomp")) return KEY_chomp;
4336 if (strEQ(d,"chmod")) return -KEY_chmod;
4337 if (strEQ(d,"chown")) return -KEY_chown;
4338 if (strEQ(d,"crypt")) return -KEY_crypt;
4341 if (strEQ(d,"chroot")) return -KEY_chroot;
4342 if (strEQ(d,"caller")) return -KEY_caller;
4345 if (strEQ(d,"connect")) return -KEY_connect;
4348 if (strEQ(d,"closedir")) return -KEY_closedir;
4349 if (strEQ(d,"continue")) return -KEY_continue;
4354 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4359 if (strEQ(d,"do")) return KEY_do;
4362 if (strEQ(d,"die")) return -KEY_die;
4365 if (strEQ(d,"dump")) return -KEY_dump;
4368 if (strEQ(d,"delete")) return KEY_delete;
4371 if (strEQ(d,"defined")) return KEY_defined;
4372 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4375 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4380 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4381 if (strEQ(d,"END")) return KEY_END;
4386 if (strEQ(d,"eq")) return -KEY_eq;
4389 if (strEQ(d,"eof")) return -KEY_eof;
4390 if (strEQ(d,"exp")) return -KEY_exp;
4393 if (strEQ(d,"else")) return KEY_else;
4394 if (strEQ(d,"exit")) return -KEY_exit;
4395 if (strEQ(d,"eval")) return KEY_eval;
4396 if (strEQ(d,"exec")) return -KEY_exec;
4397 if (strEQ(d,"each")) return KEY_each;
4400 if (strEQ(d,"elsif")) return KEY_elsif;
4403 if (strEQ(d,"exists")) return KEY_exists;
4404 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4407 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4408 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4411 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4414 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4415 if (strEQ(d,"endservent")) return -KEY_endservent;
4418 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4425 if (strEQ(d,"for")) return KEY_for;
4428 if (strEQ(d,"fork")) return -KEY_fork;
4431 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4432 if (strEQ(d,"flock")) return -KEY_flock;
4435 if (strEQ(d,"format")) return KEY_format;
4436 if (strEQ(d,"fileno")) return -KEY_fileno;
4439 if (strEQ(d,"foreach")) return KEY_foreach;
4442 if (strEQ(d,"formline")) return -KEY_formline;
4448 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4449 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4453 if (strnEQ(d,"get",3)) {
4458 if (strEQ(d,"ppid")) return -KEY_getppid;
4459 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4462 if (strEQ(d,"pwent")) return -KEY_getpwent;
4463 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4464 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4467 if (strEQ(d,"peername")) return -KEY_getpeername;
4468 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4469 if (strEQ(d,"priority")) return -KEY_getpriority;
4472 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4475 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4479 else if (*d == 'h') {
4480 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4481 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4482 if (strEQ(d,"hostent")) return -KEY_gethostent;
4484 else if (*d == 'n') {
4485 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4486 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4487 if (strEQ(d,"netent")) return -KEY_getnetent;
4489 else if (*d == 's') {
4490 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4491 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4492 if (strEQ(d,"servent")) return -KEY_getservent;
4493 if (strEQ(d,"sockname")) return -KEY_getsockname;
4494 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4496 else if (*d == 'g') {
4497 if (strEQ(d,"grent")) return -KEY_getgrent;
4498 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4499 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4501 else if (*d == 'l') {
4502 if (strEQ(d,"login")) return -KEY_getlogin;
4504 else if (strEQ(d,"c")) return -KEY_getc;
4509 if (strEQ(d,"gt")) return -KEY_gt;
4510 if (strEQ(d,"ge")) return -KEY_ge;
4513 if (strEQ(d,"grep")) return KEY_grep;
4514 if (strEQ(d,"goto")) return KEY_goto;
4515 if (strEQ(d,"glob")) return KEY_glob;
4518 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4523 if (strEQ(d,"hex")) return -KEY_hex;
4526 if (strEQ(d,"INIT")) return KEY_INIT;
4531 if (strEQ(d,"if")) return KEY_if;
4534 if (strEQ(d,"int")) return -KEY_int;
4537 if (strEQ(d,"index")) return -KEY_index;
4538 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4543 if (strEQ(d,"join")) return -KEY_join;
4547 if (strEQ(d,"keys")) return KEY_keys;
4548 if (strEQ(d,"kill")) return -KEY_kill;
4553 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4554 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4560 if (strEQ(d,"lt")) return -KEY_lt;
4561 if (strEQ(d,"le")) return -KEY_le;
4562 if (strEQ(d,"lc")) return -KEY_lc;
4565 if (strEQ(d,"log")) return -KEY_log;
4568 if (strEQ(d,"last")) return KEY_last;
4569 if (strEQ(d,"link")) return -KEY_link;
4570 if (strEQ(d,"lock")) return -KEY_lock;
4573 if (strEQ(d,"local")) return KEY_local;
4574 if (strEQ(d,"lstat")) return -KEY_lstat;
4577 if (strEQ(d,"length")) return -KEY_length;
4578 if (strEQ(d,"listen")) return -KEY_listen;
4581 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4584 if (strEQ(d,"localtime")) return -KEY_localtime;
4590 case 1: return KEY_m;
4592 if (strEQ(d,"my")) return KEY_my;
4595 if (strEQ(d,"map")) return KEY_map;
4598 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4601 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4602 if (strEQ(d,"msgget")) return -KEY_msgget;
4603 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4604 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4609 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4612 if (strEQ(d,"next")) return KEY_next;
4613 if (strEQ(d,"ne")) return -KEY_ne;
4614 if (strEQ(d,"not")) return -KEY_not;
4615 if (strEQ(d,"no")) return KEY_no;
4620 if (strEQ(d,"or")) return -KEY_or;
4623 if (strEQ(d,"ord")) return -KEY_ord;
4624 if (strEQ(d,"oct")) return -KEY_oct;
4625 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4629 if (strEQ(d,"open")) return -KEY_open;
4632 if (strEQ(d,"opendir")) return -KEY_opendir;
4639 if (strEQ(d,"pop")) return KEY_pop;
4640 if (strEQ(d,"pos")) return KEY_pos;
4643 if (strEQ(d,"push")) return KEY_push;
4644 if (strEQ(d,"pack")) return -KEY_pack;
4645 if (strEQ(d,"pipe")) return -KEY_pipe;
4648 if (strEQ(d,"print")) return KEY_print;
4651 if (strEQ(d,"printf")) return KEY_printf;
4654 if (strEQ(d,"package")) return KEY_package;
4657 if (strEQ(d,"prototype")) return KEY_prototype;
4662 if (strEQ(d,"q")) return KEY_q;
4663 if (strEQ(d,"qr")) return KEY_qr;
4664 if (strEQ(d,"qq")) return KEY_qq;
4665 if (strEQ(d,"qw")) return KEY_qw;
4666 if (strEQ(d,"qx")) return KEY_qx;
4668 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4673 if (strEQ(d,"ref")) return -KEY_ref;
4676 if (strEQ(d,"read")) return -KEY_read;
4677 if (strEQ(d,"rand")) return -KEY_rand;
4678 if (strEQ(d,"recv")) return -KEY_recv;
4679 if (strEQ(d,"redo")) return KEY_redo;
4682 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4683 if (strEQ(d,"reset")) return -KEY_reset;
4686 if (strEQ(d,"return")) return KEY_return;
4687 if (strEQ(d,"rename")) return -KEY_rename;
4688 if (strEQ(d,"rindex")) return -KEY_rindex;
4691 if (strEQ(d,"require")) return -KEY_require;
4692 if (strEQ(d,"reverse")) return -KEY_reverse;
4693 if (strEQ(d,"readdir")) return -KEY_readdir;
4696 if (strEQ(d,"readlink")) return -KEY_readlink;
4697 if (strEQ(d,"readline")) return -KEY_readline;
4698 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4701 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4707 case 0: return KEY_s;
4709 if (strEQ(d,"scalar")) return KEY_scalar;
4714 if (strEQ(d,"seek")) return -KEY_seek;
4715 if (strEQ(d,"send")) return -KEY_send;
4718 if (strEQ(d,"semop")) return -KEY_semop;
4721 if (strEQ(d,"select")) return -KEY_select;
4722 if (strEQ(d,"semctl")) return -KEY_semctl;
4723 if (strEQ(d,"semget")) return -KEY_semget;
4726 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4727 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4730 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4731 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4734 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4737 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4738 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4739 if (strEQ(d,"setservent")) return -KEY_setservent;
4742 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4743 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4750 if (strEQ(d,"shift")) return KEY_shift;
4753 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4754 if (strEQ(d,"shmget")) return -KEY_shmget;
4757 if (strEQ(d,"shmread")) return -KEY_shmread;
4760 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4761 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4766 if (strEQ(d,"sin")) return -KEY_sin;
4769 if (strEQ(d,"sleep")) return -KEY_sleep;
4772 if (strEQ(d,"sort")) return KEY_sort;
4773 if (strEQ(d,"socket")) return -KEY_socket;
4774 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4777 if (strEQ(d,"split")) return KEY_split;
4778 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4779 if (strEQ(d,"splice")) return KEY_splice;
4782 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4785 if (strEQ(d,"srand")) return -KEY_srand;
4788 if (strEQ(d,"stat")) return -KEY_stat;
4789 if (strEQ(d,"study")) return KEY_study;
4792 if (strEQ(d,"substr")) return -KEY_substr;
4793 if (strEQ(d,"sub")) return KEY_sub;
4798 if (strEQ(d,"system")) return -KEY_system;
4801 if (strEQ(d,"symlink")) return -KEY_symlink;
4802 if (strEQ(d,"syscall")) return -KEY_syscall;
4803 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4804 if (strEQ(d,"sysread")) return -KEY_sysread;
4805 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4808 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4817 if (strEQ(d,"tr")) return KEY_tr;
4820 if (strEQ(d,"tie")) return KEY_tie;
4823 if (strEQ(d,"tell")) return -KEY_tell;
4824 if (strEQ(d,"tied")) return KEY_tied;
4825 if (strEQ(d,"time")) return -KEY_time;
4828 if (strEQ(d,"times")) return -KEY_times;
4831 if (strEQ(d,"telldir")) return -KEY_telldir;
4834 if (strEQ(d,"truncate")) return -KEY_truncate;
4841 if (strEQ(d,"uc")) return -KEY_uc;
4844 if (strEQ(d,"use")) return KEY_use;
4847 if (strEQ(d,"undef")) return KEY_undef;
4848 if (strEQ(d,"until")) return KEY_until;
4849 if (strEQ(d,"untie")) return KEY_untie;
4850 if (strEQ(d,"utime")) return -KEY_utime;
4851 if (strEQ(d,"umask")) return -KEY_umask;
4854 if (strEQ(d,"unless")) return KEY_unless;
4855 if (strEQ(d,"unpack")) return -KEY_unpack;
4856 if (strEQ(d,"unlink")) return -KEY_unlink;
4859 if (strEQ(d,"unshift")) return KEY_unshift;
4860 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4865 if (strEQ(d,"values")) return -KEY_values;
4866 if (strEQ(d,"vec")) return -KEY_vec;
4871 if (strEQ(d,"warn")) return -KEY_warn;
4872 if (strEQ(d,"wait")) return -KEY_wait;
4875 if (strEQ(d,"while")) return KEY_while;
4876 if (strEQ(d,"write")) return -KEY_write;
4879 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4882 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4887 if (len == 1) return -KEY_x;
4888 if (strEQ(d,"xor")) return -KEY_xor;
4891 if (len == 1) return KEY_y;
4900 S_checkcomma(pTHX_ register char *s, char *name, char *what)
4904 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4905 dTHR; /* only for ckWARN */
4906 if (ckWARN(WARN_SYNTAX)) {
4908 for (w = s+2; *w && level; w++) {
4915 for (; *w && isSPACE(*w); w++) ;
4916 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4917 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
4920 while (s < PL_bufend && isSPACE(*s))
4924 while (s < PL_bufend && isSPACE(*s))
4926 if (isIDFIRST_lazy(s)) {
4928 while (isALNUM_lazy(s))
4930 while (s < PL_bufend && isSPACE(*s))
4935 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
4939 Perl_croak(aTHX_ "No comma allowed after %s", what);
4945 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4948 HV *table = GvHV(PL_hintgv); /* ^H */
4951 bool oldcatch = CATCH_GET;
4956 yyerror("%^H is not defined");
4959 cvp = hv_fetch(table, key, strlen(key), FALSE);
4960 if (!cvp || !SvOK(*cvp)) {
4962 sprintf(buf,"$^H{%s} is not defined", key);
4966 sv_2mortal(sv); /* Parent created it permanently */
4969 pv = sv_2mortal(newSVpvn(s, len));
4971 typesv = sv_2mortal(newSVpv(type, 0));
4973 typesv = &PL_sv_undef;
4975 Zero(&myop, 1, BINOP);
4976 myop.op_last = (OP *) &myop;
4977 myop.op_next = Nullop;
4978 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4980 PUSHSTACKi(PERLSI_OVERLOAD);
4983 PL_op = (OP *) &myop;
4984 if (PERLDB_SUB && PL_curstash != PL_debstash)
4985 PL_op->op_private |= OPpENTERSUB_DB;
4987 Perl_pp_pushmark(aTHX);
4996 if (PL_op = Perl_pp_entersub(aTHX))
5003 CATCH_SET(oldcatch);
5008 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5011 return SvREFCNT_inc(res);
5015 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5017 register char *d = dest;
5018 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5021 Perl_croak(aTHX_ ident_too_long);
5022 if (isALNUM(*s)) /* UTF handled below */
5024 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5029 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5033 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5034 char *t = s + UTF8SKIP(s);
5035 while (*t & 0x80 && is_utf8_mark((U8*)t))
5037 if (d + (t - s) > e)
5038 Perl_croak(aTHX_ ident_too_long);
5039 Copy(s, d, t - s, char);
5052 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5059 if (PL_lex_brackets == 0)
5060 PL_lex_fakebrack = 0;
5064 e = d + destlen - 3; /* two-character token, ending NUL */
5066 while (isDIGIT(*s)) {
5068 Perl_croak(aTHX_ ident_too_long);
5075 Perl_croak(aTHX_ ident_too_long);
5076 if (isALNUM(*s)) /* UTF handled below */
5078 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5083 else if (*s == ':' && s[1] == ':') {
5087 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5088 char *t = s + UTF8SKIP(s);
5089 while (*t & 0x80 && is_utf8_mark((U8*)t))
5091 if (d + (t - s) > e)
5092 Perl_croak(aTHX_ ident_too_long);
5093 Copy(s, d, t - s, char);
5104 if (PL_lex_state != LEX_NORMAL)
5105 PL_lex_state = LEX_INTERPENDMAYBE;
5108 if (*s == '$' && s[1] &&
5109 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5122 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5127 if (isSPACE(s[-1])) {
5130 if (ch != ' ' && ch != '\t') {
5136 if (isIDFIRST_lazy(d)) {
5140 while (e < send && isALNUM_lazy(e) || *e == ':') {
5142 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5145 Copy(s, d, e - s, char);
5150 while ((isALNUM(*s) || *s == ':') && d < e)
5153 Perl_croak(aTHX_ ident_too_long);
5156 while (s < send && (*s == ' ' || *s == '\t')) s++;
5157 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5158 dTHR; /* only for ckWARN */
5159 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5160 char *brack = *s == '[' ? "[...]" : "{...}";
5161 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5162 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5163 funny, dest, brack, funny, dest, brack);
5165 PL_lex_fakebrack = PL_lex_brackets+1;
5167 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5171 /* Handle extended ${^Foo} variables
5172 * 1999-02-27 mjd-perl-patch@plover.com */
5173 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5177 while (isALNUM(*s) && d < e) {
5181 Perl_croak(aTHX_ ident_too_long);
5186 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5187 PL_lex_state = LEX_INTERPEND;
5190 if (PL_lex_state == LEX_NORMAL) {
5191 dTHR; /* only for ckWARN */
5192 if (ckWARN(WARN_AMBIGUOUS) &&
5193 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5195 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5196 "Ambiguous use of %c{%s} resolved to %c%s",
5197 funny, dest, funny, dest);
5202 s = bracket; /* let the parser handle it */
5206 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5207 PL_lex_state = LEX_INTERPEND;
5212 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5217 *pmfl |= PMf_GLOBAL;
5219 *pmfl |= PMf_CONTINUE;
5223 *pmfl |= PMf_MULTILINE;
5225 *pmfl |= PMf_SINGLELINE;
5227 *pmfl |= PMf_EXTENDED;
5231 S_scan_pat(pTHX_ char *start, I32 type)
5236 s = scan_str(start);
5239 SvREFCNT_dec(PL_lex_stuff);
5240 PL_lex_stuff = Nullsv;
5241 Perl_croak(aTHX_ "Search pattern not terminated");
5244 pm = (PMOP*)newPMOP(type, 0);
5245 if (PL_multi_open == '?')
5246 pm->op_pmflags |= PMf_ONCE;
5248 while (*s && strchr("iomsx", *s))
5249 pmflag(&pm->op_pmflags,*s++);
5252 while (*s && strchr("iogcmsx", *s))
5253 pmflag(&pm->op_pmflags,*s++);
5255 pm->op_pmpermflags = pm->op_pmflags;
5257 PL_lex_op = (OP*)pm;
5258 yylval.ival = OP_MATCH;
5263 S_scan_subst(pTHX_ char *start)
5270 yylval.ival = OP_NULL;
5272 s = scan_str(start);
5276 SvREFCNT_dec(PL_lex_stuff);
5277 PL_lex_stuff = Nullsv;
5278 Perl_croak(aTHX_ "Substitution pattern not terminated");
5281 if (s[-1] == PL_multi_open)
5284 first_start = PL_multi_start;
5288 SvREFCNT_dec(PL_lex_stuff);
5289 PL_lex_stuff = Nullsv;
5291 SvREFCNT_dec(PL_lex_repl);
5292 PL_lex_repl = Nullsv;
5293 Perl_croak(aTHX_ "Substitution replacement not terminated");
5295 PL_multi_start = first_start; /* so whole substitution is taken together */
5297 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5303 else if (strchr("iogcmsx", *s))
5304 pmflag(&pm->op_pmflags,*s++);
5311 PL_sublex_info.super_bufptr = s;
5312 PL_sublex_info.super_bufend = PL_bufend;
5314 pm->op_pmflags |= PMf_EVAL;
5315 repl = newSVpvn("",0);
5317 sv_catpv(repl, es ? "eval " : "do ");
5318 sv_catpvn(repl, "{ ", 2);
5319 sv_catsv(repl, PL_lex_repl);
5320 sv_catpvn(repl, " };", 2);
5322 SvREFCNT_dec(PL_lex_repl);
5326 pm->op_pmpermflags = pm->op_pmflags;
5327 PL_lex_op = (OP*)pm;
5328 yylval.ival = OP_SUBST;
5333 S_scan_trans(pTHX_ char *start)
5344 yylval.ival = OP_NULL;
5346 s = scan_str(start);
5349 SvREFCNT_dec(PL_lex_stuff);
5350 PL_lex_stuff = Nullsv;
5351 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5353 if (s[-1] == PL_multi_open)
5359 SvREFCNT_dec(PL_lex_stuff);
5360 PL_lex_stuff = Nullsv;
5362 SvREFCNT_dec(PL_lex_repl);
5363 PL_lex_repl = Nullsv;
5364 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5368 o = newSVOP(OP_TRANS, 0, 0);
5369 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5372 New(803,tbl,256,short);
5373 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5377 complement = del = squash = 0;
5378 while (strchr("cdsCU", *s)) {
5380 complement = OPpTRANS_COMPLEMENT;
5382 del = OPpTRANS_DELETE;
5384 squash = OPpTRANS_SQUASH;
5389 utf8 &= ~OPpTRANS_FROM_UTF;
5391 utf8 |= OPpTRANS_FROM_UTF;
5395 utf8 &= ~OPpTRANS_TO_UTF;
5397 utf8 |= OPpTRANS_TO_UTF;
5400 Perl_croak(aTHX_ "Too many /C and /U options");
5405 o->op_private = del|squash|complement|utf8;
5408 yylval.ival = OP_TRANS;
5413 S_scan_heredoc(pTHX_ register char *s)
5417 I32 op_type = OP_SCALAR;
5424 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5428 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5431 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5432 if (*peek && strchr("`'\"",*peek)) {
5435 s = delimcpy(d, e, s, PL_bufend, term, &len);
5445 if (!isALNUM_lazy(s))
5446 deprecate("bare << to mean <<\"\"");
5447 for (; isALNUM_lazy(s); s++) {
5452 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5453 Perl_croak(aTHX_ "Delimiter for here document is too long");
5456 len = d - PL_tokenbuf;
5457 #ifndef PERL_STRICT_CR
5458 d = strchr(s, '\r');
5462 while (s < PL_bufend) {
5468 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5477 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5482 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5483 herewas = newSVpvn(s,PL_bufend-s);
5485 s--, herewas = newSVpvn(s,d-s);
5486 s += SvCUR(herewas);
5488 tmpstr = NEWSV(87,79);
5489 sv_upgrade(tmpstr, SVt_PVIV);
5494 else if (term == '`') {
5495 op_type = OP_BACKTICK;
5496 SvIVX(tmpstr) = '\\';
5500 PL_multi_start = PL_curcop->cop_line;
5501 PL_multi_open = PL_multi_close = '<';
5502 term = *PL_tokenbuf;
5503 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5504 char *bufptr = PL_sublex_info.super_bufptr;
5505 char *bufend = PL_sublex_info.super_bufend;
5506 char *olds = s - SvCUR(herewas);
5507 s = strchr(bufptr, '\n');
5511 while (s < bufend &&
5512 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5514 PL_curcop->cop_line++;
5517 PL_curcop->cop_line = PL_multi_start;
5518 missingterm(PL_tokenbuf);
5520 sv_setpvn(herewas,bufptr,d-bufptr+1);
5521 sv_setpvn(tmpstr,d+1,s-d);
5523 sv_catpvn(herewas,s,bufend-s);
5524 (void)strcpy(bufptr,SvPVX(herewas));
5531 while (s < PL_bufend &&
5532 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5534 PL_curcop->cop_line++;
5536 if (s >= PL_bufend) {
5537 PL_curcop->cop_line = PL_multi_start;
5538 missingterm(PL_tokenbuf);
5540 sv_setpvn(tmpstr,d+1,s-d);
5542 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5544 sv_catpvn(herewas,s,PL_bufend-s);
5545 sv_setsv(PL_linestr,herewas);
5546 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5547 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5550 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5551 while (s >= PL_bufend) { /* multiple line string? */
5553 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5554 PL_curcop->cop_line = PL_multi_start;
5555 missingterm(PL_tokenbuf);
5557 PL_curcop->cop_line++;
5558 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5559 #ifndef PERL_STRICT_CR
5560 if (PL_bufend - PL_linestart >= 2) {
5561 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5562 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5564 PL_bufend[-2] = '\n';
5566 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5568 else if (PL_bufend[-1] == '\r')
5569 PL_bufend[-1] = '\n';
5571 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5572 PL_bufend[-1] = '\n';
5574 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5575 SV *sv = NEWSV(88,0);
5577 sv_upgrade(sv, SVt_PVMG);
5578 sv_setsv(sv,PL_linestr);
5579 av_store(GvAV(PL_curcop->cop_filegv),
5580 (I32)PL_curcop->cop_line,sv);
5582 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5585 sv_catsv(PL_linestr,herewas);
5586 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5590 sv_catsv(tmpstr,PL_linestr);
5595 PL_multi_end = PL_curcop->cop_line;
5596 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5597 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5598 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5600 SvREFCNT_dec(herewas);
5601 PL_lex_stuff = tmpstr;
5602 yylval.ival = op_type;
5607 takes: current position in input buffer
5608 returns: new position in input buffer
5609 side-effects: yylval and lex_op are set.
5614 <FH> read from filehandle
5615 <pkg::FH> read from package qualified filehandle
5616 <pkg'FH> read from package qualified filehandle
5617 <$fh> read from filehandle in $fh
5623 S_scan_inputsymbol(pTHX_ char *start)
5625 register char *s = start; /* current position in buffer */
5631 d = PL_tokenbuf; /* start of temp holding space */
5632 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5633 end = strchr(s, '\n');
5636 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
5638 /* die if we didn't have space for the contents of the <>,
5639 or if it didn't end, or if we see a newline
5642 if (len >= sizeof PL_tokenbuf)
5643 Perl_croak(aTHX_ "Excessively long <> operator");
5645 Perl_croak(aTHX_ "Unterminated <> operator");
5650 Remember, only scalar variables are interpreted as filehandles by
5651 this code. Anything more complex (e.g., <$fh{$num}>) will be
5652 treated as a glob() call.
5653 This code makes use of the fact that except for the $ at the front,
5654 a scalar variable and a filehandle look the same.
5656 if (*d == '$' && d[1]) d++;
5658 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5659 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5662 /* If we've tried to read what we allow filehandles to look like, and
5663 there's still text left, then it must be a glob() and not a getline.
5664 Use scan_str to pull out the stuff between the <> and treat it
5665 as nothing more than a string.
5668 if (d - PL_tokenbuf != len) {
5669 yylval.ival = OP_GLOB;
5671 s = scan_str(start);
5673 Perl_croak(aTHX_ "Glob not terminated");
5677 /* we're in a filehandle read situation */
5680 /* turn <> into <ARGV> */
5682 (void)strcpy(d,"ARGV");
5684 /* if <$fh>, create the ops to turn the variable into a
5690 /* try to find it in the pad for this block, otherwise find
5691 add symbol table ops
5693 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5694 OP *o = newOP(OP_PADSV, 0);
5696 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5699 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5700 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5701 newUNOP(OP_RV2SV, 0,
5702 newGVOP(OP_GV, 0, gv)));
5704 PL_lex_op->op_flags |= OPf_SPECIAL;
5705 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5706 yylval.ival = OP_NULL;
5709 /* If it's none of the above, it must be a literal filehandle
5710 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5712 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5713 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5714 yylval.ival = OP_NULL;
5723 takes: start position in buffer
5724 returns: position to continue reading from buffer
5725 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5726 updates the read buffer.
5728 This subroutine pulls a string out of the input. It is called for:
5729 q single quotes q(literal text)
5730 ' single quotes 'literal text'
5731 qq double quotes qq(interpolate $here please)
5732 " double quotes "interpolate $here please"
5733 qx backticks qx(/bin/ls -l)
5734 ` backticks `/bin/ls -l`
5735 qw quote words @EXPORT_OK = qw( func() $spam )
5736 m// regexp match m/this/
5737 s/// regexp substitute s/this/that/
5738 tr/// string transliterate tr/this/that/
5739 y/// string transliterate y/this/that/
5740 ($*@) sub prototypes sub foo ($)
5741 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5743 In most of these cases (all but <>, patterns and transliterate)
5744 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5745 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5746 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5749 It skips whitespace before the string starts, and treats the first
5750 character as the delimiter. If the delimiter is one of ([{< then
5751 the corresponding "close" character )]}> is used as the closing
5752 delimiter. It allows quoting of delimiters, and if the string has
5753 balanced delimiters ([{<>}]) it allows nesting.
5755 The lexer always reads these strings into lex_stuff, except in the
5756 case of the operators which take *two* arguments (s/// and tr///)
5757 when it checks to see if lex_stuff is full (presumably with the 1st
5758 arg to s or tr) and if so puts the string into lex_repl.
5763 S_scan_str(pTHX_ char *start)
5766 SV *sv; /* scalar value: string */
5767 char *tmps; /* temp string, used for delimiter matching */
5768 register char *s = start; /* current position in the buffer */
5769 register char term; /* terminating character */
5770 register char *to; /* current position in the sv's data */
5771 I32 brackets = 1; /* bracket nesting level */
5773 /* skip space before the delimiter */
5777 /* mark where we are, in case we need to report errors */
5780 /* after skipping whitespace, the next character is the terminator */
5782 /* mark where we are */
5783 PL_multi_start = PL_curcop->cop_line;
5784 PL_multi_open = term;
5786 /* find corresponding closing delimiter */
5787 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5789 PL_multi_close = term;
5791 /* create a new SV to hold the contents. 87 is leak category, I'm
5792 assuming. 79 is the SV's initial length. What a random number. */
5794 sv_upgrade(sv, SVt_PVIV);
5796 (void)SvPOK_only(sv); /* validate pointer */
5798 /* move past delimiter and try to read a complete string */
5801 /* extend sv if need be */
5802 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5803 /* set 'to' to the next character in the sv's string */
5804 to = SvPVX(sv)+SvCUR(sv);
5806 /* if open delimiter is the close delimiter read unbridle */
5807 if (PL_multi_open == PL_multi_close) {
5808 for (; s < PL_bufend; s++,to++) {
5809 /* embedded newlines increment the current line number */
5810 if (*s == '\n' && !PL_rsfp)
5811 PL_curcop->cop_line++;
5812 /* handle quoted delimiters */
5813 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5816 /* any other quotes are simply copied straight through */
5820 /* terminate when run out of buffer (the for() condition), or
5821 have found the terminator */
5822 else if (*s == term)
5828 /* if the terminator isn't the same as the start character (e.g.,
5829 matched brackets), we have to allow more in the quoting, and
5830 be prepared for nested brackets.
5833 /* read until we run out of string, or we find the terminator */
5834 for (; s < PL_bufend; s++,to++) {
5835 /* embedded newlines increment the line count */
5836 if (*s == '\n' && !PL_rsfp)
5837 PL_curcop->cop_line++;
5838 /* backslashes can escape the open or closing characters */
5839 if (*s == '\\' && s+1 < PL_bufend) {
5840 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5845 /* allow nested opens and closes */
5846 else if (*s == PL_multi_close && --brackets <= 0)
5848 else if (*s == PL_multi_open)
5853 /* terminate the copied string and update the sv's end-of-string */
5855 SvCUR_set(sv, to - SvPVX(sv));
5858 * this next chunk reads more into the buffer if we're not done yet
5861 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5863 #ifndef PERL_STRICT_CR
5864 if (to - SvPVX(sv) >= 2) {
5865 if ((to[-2] == '\r' && to[-1] == '\n') ||
5866 (to[-2] == '\n' && to[-1] == '\r'))
5870 SvCUR_set(sv, to - SvPVX(sv));
5872 else if (to[-1] == '\r')
5875 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5879 /* if we're out of file, or a read fails, bail and reset the current
5880 line marker so we can report where the unterminated string began
5883 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5885 PL_curcop->cop_line = PL_multi_start;
5888 /* we read a line, so increment our line counter */
5889 PL_curcop->cop_line++;
5891 /* update debugger info */
5892 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5893 SV *sv = NEWSV(88,0);
5895 sv_upgrade(sv, SVt_PVMG);
5896 sv_setsv(sv,PL_linestr);
5897 av_store(GvAV(PL_curcop->cop_filegv),
5898 (I32)PL_curcop->cop_line, sv);
5901 /* having changed the buffer, we must update PL_bufend */
5902 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5905 /* at this point, we have successfully read the delimited string */
5907 PL_multi_end = PL_curcop->cop_line;
5910 /* if we allocated too much space, give some back */
5911 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5912 SvLEN_set(sv, SvCUR(sv) + 1);
5913 Renew(SvPVX(sv), SvLEN(sv), char);
5916 /* decide whether this is the first or second quoted string we've read
5929 takes: pointer to position in buffer
5930 returns: pointer to new position in buffer
5931 side-effects: builds ops for the constant in yylval.op
5933 Read a number in any of the formats that Perl accepts:
5935 0(x[0-7A-F]+)|([0-7]+)|(b[01])
5936 [\d_]+(\.[\d_]*)?[Ee](\d+)
5938 Underbars (_) are allowed in decimal numbers. If -w is on,
5939 underbars before a decimal point must be at three digit intervals.
5941 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5944 If it reads a number without a decimal point or an exponent, it will
5945 try converting the number to an integer and see if it can do so
5946 without loss of precision.
5950 Perl_scan_num(pTHX_ char *start)
5952 register char *s = start; /* current position in buffer */
5953 register char *d; /* destination in temp buffer */
5954 register char *e; /* end of temp buffer */
5955 I32 tryiv; /* used to see if it can be an int */
5956 double value; /* number read, as a double */
5957 SV *sv; /* place to put the converted number */
5958 I32 floatit; /* boolean: int or float? */
5959 char *lastub = 0; /* position of last underbar */
5960 static char number_too_long[] = "Number too long";
5962 /* We use the first character to decide what type of number this is */
5966 Perl_croak(aTHX_ "panic: scan_num");
5968 /* if it starts with a 0, it could be an octal number, a decimal in
5969 0.13 disguise, or a hexadecimal number, or a binary number.
5974 u holds the "number so far"
5975 shift the power of 2 of the base
5976 (hex == 4, octal == 3, binary == 1)
5977 overflowed was the number more than we can hold?
5979 Shift is used when we add a digit. It also serves as an "are
5980 we in octal/hex/binary?" indicator to disallow hex characters
5985 bool overflowed = FALSE;
5991 } else if (s[1] == 'b') {
5995 /* check for a decimal in disguise */
5996 else if (s[1] == '.')
5998 /* so it must be octal */
6003 /* read the rest of the number */
6005 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
6009 /* if we don't mention it, we're done */
6018 /* 8 and 9 are not octal */
6021 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6024 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6028 case '2': case '3': case '4':
6029 case '5': case '6': case '7':
6031 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6035 b = *s++ & 15; /* ASCII digit -> value of digit */
6039 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6040 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6041 /* make sure they said 0x */
6046 /* Prepare to put the digit we have onto the end
6047 of the number so far. We check for overflows.
6051 n = u << shift; /* make room for the digit */
6052 if (!overflowed && (n >> shift) != u
6053 && !(PL_hints & HINT_NEW_BINARY)) {
6054 Perl_warn(aTHX_ "Integer overflow in %s number",
6055 (shift == 4) ? "hex"
6056 : ((shift == 3) ? "octal" : "binary"));
6059 u = n | b; /* add the digit to the end */
6064 /* if we get here, we had success: make a scalar value from
6070 if ( PL_hints & HINT_NEW_BINARY)
6071 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6076 handle decimal numbers.
6077 we're also sent here when we read a 0 as the first digit
6079 case '1': case '2': case '3': case '4': case '5':
6080 case '6': case '7': case '8': case '9': case '.':
6083 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6086 /* read next group of digits and _ and copy into d */
6087 while (isDIGIT(*s) || *s == '_') {
6088 /* skip underscores, checking for misplaced ones
6092 dTHR; /* only for ckWARN */
6093 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6094 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6098 /* check for end of fixed-length buffer */
6100 Perl_croak(aTHX_ number_too_long);
6101 /* if we're ok, copy the character */
6106 /* final misplaced underbar check */
6107 if (lastub && s - lastub != 3) {
6109 if (ckWARN(WARN_SYNTAX))
6110 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6113 /* read a decimal portion if there is one. avoid
6114 3..5 being interpreted as the number 3. followed
6117 if (*s == '.' && s[1] != '.') {
6121 /* copy, ignoring underbars, until we run out of
6122 digits. Note: no misplaced underbar checks!
6124 for (; isDIGIT(*s) || *s == '_'; s++) {
6125 /* fixed length buffer check */
6127 Perl_croak(aTHX_ number_too_long);
6133 /* read exponent part, if present */
6134 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6138 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6139 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6141 /* allow positive or negative exponent */
6142 if (*s == '+' || *s == '-')
6145 /* read digits of exponent (no underbars :-) */
6146 while (isDIGIT(*s)) {
6148 Perl_croak(aTHX_ number_too_long);
6153 /* terminate the string */
6156 /* make an sv from the string */
6159 value = Atof(PL_tokenbuf);
6162 See if we can make do with an integer value without loss of
6163 precision. We use I_V to cast to an int, because some
6164 compilers have issues. Then we try casting it back and see
6165 if it was the same. We only do this if we know we
6166 specifically read an integer.
6168 Note: if floatit is true, then we don't need to do the
6172 if (!floatit && (double)tryiv == value)
6173 sv_setiv(sv, tryiv);
6175 sv_setnv(sv, value);
6176 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6177 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6178 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6182 /* make the op for the constant and return */
6184 yylval.opval = newSVOP(OP_CONST, 0, sv);
6190 S_scan_formline(pTHX_ register char *s)
6195 SV *stuff = newSVpvn("",0);
6196 bool needargs = FALSE;
6199 if (*s == '.' || *s == '}') {
6201 #ifdef PERL_STRICT_CR
6202 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6204 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6206 if (*t == '\n' || t == PL_bufend)
6209 if (PL_in_eval && !PL_rsfp) {
6210 eol = strchr(s,'\n');
6215 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6217 for (t = s; t < eol; t++) {
6218 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6220 goto enough; /* ~~ must be first line in formline */
6222 if (*t == '@' || *t == '^')
6225 sv_catpvn(stuff, s, eol-s);
6229 s = filter_gets(PL_linestr, PL_rsfp, 0);
6230 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6231 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6234 yyerror("Format not terminated");
6244 PL_lex_state = LEX_NORMAL;
6245 PL_nextval[PL_nexttoke].ival = 0;
6249 PL_lex_state = LEX_FORMLINE;
6250 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6252 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6256 SvREFCNT_dec(stuff);
6257 PL_lex_formbrack = 0;
6268 PL_cshlen = strlen(PL_cshname);
6273 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6276 I32 oldsavestack_ix = PL_savestack_ix;
6277 CV* outsidecv = PL_compcv;
6281 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6283 save_I32(&PL_subline);
6284 save_item(PL_subname);
6286 SAVESPTR(PL_curpad);
6287 SAVESPTR(PL_comppad);
6288 SAVESPTR(PL_comppad_name);
6289 SAVESPTR(PL_compcv);
6290 SAVEI32(PL_comppad_name_fill);
6291 SAVEI32(PL_min_intro_pending);
6292 SAVEI32(PL_max_intro_pending);
6293 SAVEI32(PL_pad_reset_pending);
6295 PL_compcv = (CV*)NEWSV(1104,0);
6296 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6297 CvFLAGS(PL_compcv) |= flags;
6299 PL_comppad = newAV();
6300 av_push(PL_comppad, Nullsv);
6301 PL_curpad = AvARRAY(PL_comppad);
6302 PL_comppad_name = newAV();
6303 PL_comppad_name_fill = 0;
6304 PL_min_intro_pending = 0;
6306 PL_subline = PL_curcop->cop_line;
6308 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6309 PL_curpad[0] = (SV*)newAV();
6310 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6311 #endif /* USE_THREADS */
6313 comppadlist = newAV();
6314 AvREAL_off(comppadlist);
6315 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6316 av_store(comppadlist, 1, (SV*)PL_comppad);
6318 CvPADLIST(PL_compcv) = comppadlist;
6319 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6321 CvOWNER(PL_compcv) = 0;
6322 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6323 MUTEX_INIT(CvMUTEXP(PL_compcv));
6324 #endif /* USE_THREADS */
6326 return oldsavestack_ix;
6330 Perl_yywarn(pTHX_ char *s)
6334 PL_in_eval |= EVAL_WARNONLY;
6336 PL_in_eval &= ~EVAL_WARNONLY;
6341 Perl_yyerror(pTHX_ char *s)
6345 char *context = NULL;
6349 if (!yychar || (yychar == ';' && !PL_rsfp))
6351 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6352 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6353 while (isSPACE(*PL_oldoldbufptr))
6355 context = PL_oldoldbufptr;
6356 contlen = PL_bufptr - PL_oldoldbufptr;
6358 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6359 PL_oldbufptr != PL_bufptr) {
6360 while (isSPACE(*PL_oldbufptr))
6362 context = PL_oldbufptr;
6363 contlen = PL_bufptr - PL_oldbufptr;
6365 else if (yychar > 255)
6366 where = "next token ???";
6367 else if ((yychar & 127) == 127) {
6368 if (PL_lex_state == LEX_NORMAL ||
6369 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6370 where = "at end of line";
6371 else if (PL_lex_inpat)
6372 where = "within pattern";
6374 where = "within string";
6377 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6379 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6380 else if (isPRINT_LC(yychar))
6381 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6383 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6384 where = SvPVX(where_sv);
6386 msg = sv_2mortal(newSVpv(s, 0));
6387 Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6388 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6390 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6392 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6393 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6394 Perl_sv_catpvf(aTHX_ msg,
6395 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6396 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6399 if (PL_in_eval & EVAL_WARNONLY)
6400 Perl_warn(aTHX_ "%_", msg);
6401 else if (PL_in_eval)
6402 sv_catsv(ERRSV, msg);
6404 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6405 if (++PL_error_count >= 10)
6406 Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6408 PL_in_my_stash = Nullhv;