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 static void restore_rsfp(pTHXo_ void *f);
24 static void restore_expect(pTHXo_ void *e);
25 static void restore_lex_expect(pTHXo_ void *e);
27 #define UTF (PL_hints & HINT_UTF8)
29 * Note: we try to be careful never to call the isXXX_utf8() functions
30 * unless we're pretty sure we've seen the beginning of a UTF-8 character
31 * (that is, the two high bits are set). Otherwise we risk loading in the
32 * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
34 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
36 : isIDFIRST_utf8((U8*)p))
37 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
39 : isALNUM_utf8((U8*)p))
41 /* In variables name $^X, these are the legal values for X.
42 * 1999-02-27 mjd-perl-patch@plover.com */
43 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
45 /* The following are arranged oddly so that the guard on the switch statement
46 * can get by with a single comparison (if the compiler is smart enough).
49 /* #define LEX_NOTPARSING 11 is done in perl.h. */
52 #define LEX_INTERPNORMAL 9
53 #define LEX_INTERPCASEMOD 8
54 #define LEX_INTERPPUSH 7
55 #define LEX_INTERPSTART 6
56 #define LEX_INTERPEND 5
57 #define LEX_INTERPENDMAYBE 4
58 #define LEX_INTERPCONCAT 3
59 #define LEX_INTERPCONST 2
60 #define LEX_FORMLINE 1
61 #define LEX_KNOWNEXT 0
70 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
72 # include <unistd.h> /* Needed for execv() */
81 YYSTYPE* yylval_pointer = NULL;
82 int* yychar_pointer = NULL;
85 # define yylval (*yylval_pointer)
86 # define yychar (*yychar_pointer)
87 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
89 # define yylex() Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
97 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
99 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
100 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
101 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
102 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
103 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
104 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
105 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
106 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
107 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
108 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
109 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
110 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
111 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
112 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
113 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
114 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
115 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
116 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
117 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
118 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
120 /* This bit of chicanery makes a unary function followed by
121 * a parenthesis into a function with one argument, highest precedence.
123 #define UNI(f) return(yylval.ival = f, \
126 PL_last_uni = PL_oldbufptr, \
127 PL_last_lop_op = f, \
128 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
130 #define UNIBRACK(f) return(yylval.ival = f, \
132 PL_last_uni = PL_oldbufptr, \
133 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
135 /* grandfather return to old style */
136 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
139 S_ao(pTHX_ int toketype)
141 if (*PL_bufptr == '=') {
143 if (toketype == ANDAND)
144 yylval.ival = OP_ANDASSIGN;
145 else if (toketype == OROR)
146 yylval.ival = OP_ORASSIGN;
153 S_no_op(pTHX_ char *what, char *s)
155 char *oldbp = PL_bufptr;
156 bool is_first = (PL_oldbufptr == PL_linestart);
159 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
161 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
162 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
164 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
165 if (t < PL_bufptr && isSPACE(*t))
166 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
167 t - PL_oldoldbufptr, PL_oldoldbufptr);
171 Perl_warn(aTHX_ "\t(Missing operator before end of line?)\n");
173 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
178 S_missingterm(pTHX_ char *s)
183 char *nl = strrchr(s,'\n');
189 iscntrl(PL_multi_close)
191 PL_multi_close < 32 || PL_multi_close == 127
195 tmpbuf[1] = toCTRL(PL_multi_close);
201 *tmpbuf = PL_multi_close;
205 q = strchr(s,'"') ? '\'' : '"';
206 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
210 Perl_deprecate(pTHX_ char *s)
213 if (ckWARN(WARN_DEPRECATED))
214 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
220 deprecate("comma-less variable list");
226 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
228 I32 count = FILTER_READ(idx+1, sv, maxlen);
229 if (count > 0 && !maxlen)
230 win32_strip_return(sv);
236 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
238 I32 count = FILTER_READ(idx+1, sv, maxlen);
242 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
243 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
244 sv_usepvn(sv, (char*)tmps, tend - tmps);
251 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
253 I32 count = FILTER_READ(idx+1, sv, maxlen);
257 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
258 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
259 sv_usepvn(sv, (char*)tmps, tend - tmps);
266 Perl_lex_start(pTHX_ SV *line)
272 SAVEI32(PL_lex_dojoin);
273 SAVEI32(PL_lex_brackets);
274 SAVEI32(PL_lex_fakebrack);
275 SAVEI32(PL_lex_casemods);
276 SAVEI32(PL_lex_starts);
277 SAVEI32(PL_lex_state);
278 SAVESPTR(PL_lex_inpat);
279 SAVEI32(PL_lex_inwhat);
280 SAVEI16(PL_curcop->cop_line);
283 SAVEPPTR(PL_oldbufptr);
284 SAVEPPTR(PL_oldoldbufptr);
285 SAVEPPTR(PL_linestart);
286 SAVESPTR(PL_linestr);
287 SAVEPPTR(PL_lex_brackstack);
288 SAVEPPTR(PL_lex_casestack);
289 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
290 SAVESPTR(PL_lex_stuff);
291 SAVEI32(PL_lex_defer);
292 SAVESPTR(PL_lex_repl);
293 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
294 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
296 PL_lex_state = LEX_NORMAL;
300 PL_lex_fakebrack = 0;
301 New(899, PL_lex_brackstack, 120, char);
302 New(899, PL_lex_casestack, 12, char);
303 SAVEFREEPV(PL_lex_brackstack);
304 SAVEFREEPV(PL_lex_casestack);
306 *PL_lex_casestack = '\0';
309 PL_lex_stuff = Nullsv;
310 PL_lex_repl = Nullsv;
314 if (SvREADONLY(PL_linestr))
315 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
316 s = SvPV(PL_linestr, len);
317 if (len && s[len-1] != ';') {
318 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
319 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
320 sv_catpvn(PL_linestr, "\n;", 2);
322 SvTEMP_off(PL_linestr);
323 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
324 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
326 PL_rs = newSVpvn("\n", 1);
333 PL_doextract = FALSE;
337 S_incline(pTHX_ char *s)
345 PL_curcop->cop_line++;
348 while (*s == ' ' || *s == '\t') s++;
349 if (strnEQ(s, "line ", 5)) {
358 while (*s == ' ' || *s == '\t')
360 if (*s == '"' && (t = strchr(s+1, '"')))
364 return; /* false alarm */
365 for (t = s; !isSPACE(*t); t++) ;
370 PL_curcop->cop_filegv = gv_fetchfile(s);
372 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
374 PL_curcop->cop_line = atoi(n)-1;
378 S_skipspace(pTHX_ register char *s)
381 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
382 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
388 while (s < PL_bufend && isSPACE(*s)) {
389 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
392 if (s < PL_bufend && *s == '#') {
393 while (s < PL_bufend && *s != '\n')
397 if (PL_in_eval && !PL_rsfp) {
403 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
405 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
406 if (PL_minus_n || PL_minus_p) {
407 sv_setpv(PL_linestr,PL_minus_p ?
408 ";}continue{print or die qq(-p destination: $!\\n)" :
410 sv_catpv(PL_linestr,";}");
411 PL_minus_n = PL_minus_p = 0;
414 sv_setpv(PL_linestr,";");
415 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
416 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
417 if (PL_preprocess && !PL_in_eval)
418 (void)PerlProc_pclose(PL_rsfp);
419 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
420 PerlIO_clearerr(PL_rsfp);
422 (void)PerlIO_close(PL_rsfp);
426 PL_linestart = PL_bufptr = s + prevlen;
427 PL_bufend = s + SvCUR(PL_linestr);
430 if (PERLDB_LINE && PL_curstash != PL_debstash) {
431 SV *sv = NEWSV(85,0);
433 sv_upgrade(sv, SVt_PVMG);
434 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
435 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
447 if (PL_oldoldbufptr != PL_last_uni)
449 while (isSPACE(*PL_last_uni))
451 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
452 if ((t = strchr(s, '(')) && t < PL_bufptr)
454 if (ckWARN_d(WARN_AMBIGUOUS)){
457 Perl_warner(aTHX_ WARN_AMBIGUOUS,
458 "Warning: Use of \"%s\" without parens is ambiguous",
467 #define UNI(f) return uni(f,s)
470 S_uni(pTHX_ I32 f, char *s)
475 PL_last_uni = PL_oldbufptr;
486 #endif /* CRIPPLED_CC */
488 #define LOP(f,x) return lop(f,x,s)
491 S_lop(pTHX_ I32 f, expectation x, char *s)
498 PL_last_lop = PL_oldbufptr;
512 S_force_next(pTHX_ I32 type)
514 PL_nexttype[PL_nexttoke] = type;
516 if (PL_lex_state != LEX_KNOWNEXT) {
517 PL_lex_defer = PL_lex_state;
518 PL_lex_expect = PL_expect;
519 PL_lex_state = LEX_KNOWNEXT;
524 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
529 start = skipspace(start);
531 if (isIDFIRST_lazy(s) ||
532 (allow_pack && *s == ':') ||
533 (allow_initial_tick && *s == '\'') )
535 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
536 if (check_keyword && keyword(PL_tokenbuf, len))
538 if (token == METHOD) {
543 PL_expect = XOPERATOR;
546 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
547 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
554 S_force_ident(pTHX_ register char *s, int kind)
557 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
558 PL_nextval[PL_nexttoke].opval = o;
561 dTHR; /* just for in_eval */
562 o->op_private = OPpCONST_ENTERED;
563 /* XXX see note in pp_entereval() for why we forgo typo
564 warnings if the symbol must be introduced in an eval.
566 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
567 kind == '$' ? SVt_PV :
568 kind == '@' ? SVt_PVAV :
569 kind == '%' ? SVt_PVHV :
577 S_force_version(pTHX_ char *s)
579 OP *version = Nullop;
583 /* default VERSION number -- GBARR */
588 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
589 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
591 /* real VERSION number -- GBARR */
592 version = yylval.opval;
596 /* NOTE: The parser sees the package name and the VERSION swapped */
597 PL_nextval[PL_nexttoke].opval = version;
604 S_tokeq(pTHX_ SV *sv)
615 s = SvPV_force(sv, len);
619 while (s < send && *s != '\\')
624 if ( PL_hints & HINT_NEW_STRING )
625 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
628 if (s + 1 < send && (s[1] == '\\'))
629 s++; /* all that, just for this */
634 SvCUR_set(sv, d - SvPVX(sv));
636 if ( PL_hints & HINT_NEW_STRING )
637 return new_constant(NULL, 0, "q", sv, pv, "q");
644 register I32 op_type = yylval.ival;
646 if (op_type == OP_NULL) {
647 yylval.opval = PL_lex_op;
651 if (op_type == OP_CONST || op_type == OP_READLINE) {
652 SV *sv = tokeq(PL_lex_stuff);
654 if (SvTYPE(sv) == SVt_PVIV) {
655 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
661 nsv = newSVpvn(p, len);
665 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
666 PL_lex_stuff = Nullsv;
670 PL_sublex_info.super_state = PL_lex_state;
671 PL_sublex_info.sub_inwhat = op_type;
672 PL_sublex_info.sub_op = PL_lex_op;
673 PL_lex_state = LEX_INTERPPUSH;
677 yylval.opval = PL_lex_op;
691 PL_lex_state = PL_sublex_info.super_state;
692 SAVEI32(PL_lex_dojoin);
693 SAVEI32(PL_lex_brackets);
694 SAVEI32(PL_lex_fakebrack);
695 SAVEI32(PL_lex_casemods);
696 SAVEI32(PL_lex_starts);
697 SAVEI32(PL_lex_state);
698 SAVESPTR(PL_lex_inpat);
699 SAVEI32(PL_lex_inwhat);
700 SAVEI16(PL_curcop->cop_line);
702 SAVEPPTR(PL_oldbufptr);
703 SAVEPPTR(PL_oldoldbufptr);
704 SAVEPPTR(PL_linestart);
705 SAVESPTR(PL_linestr);
706 SAVEPPTR(PL_lex_brackstack);
707 SAVEPPTR(PL_lex_casestack);
709 PL_linestr = PL_lex_stuff;
710 PL_lex_stuff = Nullsv;
712 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
713 PL_bufend += SvCUR(PL_linestr);
714 SAVEFREESV(PL_linestr);
716 PL_lex_dojoin = FALSE;
718 PL_lex_fakebrack = 0;
719 New(899, PL_lex_brackstack, 120, char);
720 New(899, PL_lex_casestack, 12, char);
721 SAVEFREEPV(PL_lex_brackstack);
722 SAVEFREEPV(PL_lex_casestack);
724 *PL_lex_casestack = '\0';
726 PL_lex_state = LEX_INTERPCONCAT;
727 PL_curcop->cop_line = PL_multi_start;
729 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
730 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
731 PL_lex_inpat = PL_sublex_info.sub_op;
733 PL_lex_inpat = Nullop;
741 if (!PL_lex_starts++) {
742 PL_expect = XOPERATOR;
743 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
747 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
748 PL_lex_state = LEX_INTERPCASEMOD;
752 /* Is there a right-hand side to take care of? */
753 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
754 PL_linestr = PL_lex_repl;
756 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
757 PL_bufend += SvCUR(PL_linestr);
758 SAVEFREESV(PL_linestr);
759 PL_lex_dojoin = FALSE;
761 PL_lex_fakebrack = 0;
763 *PL_lex_casestack = '\0';
765 if (SvEVALED(PL_lex_repl)) {
766 PL_lex_state = LEX_INTERPNORMAL;
768 /* we don't clear PL_lex_repl here, so that we can check later
769 whether this is an evalled subst; that means we rely on the
770 logic to ensure sublex_done() is called again only via the
771 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
774 PL_lex_state = LEX_INTERPCONCAT;
775 PL_lex_repl = Nullsv;
781 PL_bufend = SvPVX(PL_linestr);
782 PL_bufend += SvCUR(PL_linestr);
783 PL_expect = XOPERATOR;
791 Extracts a pattern, double-quoted string, or transliteration. This
794 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
795 processing a pattern (PL_lex_inpat is true), a transliteration
796 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
798 Returns a pointer to the character scanned up to. Iff this is
799 advanced from the start pointer supplied (ie if anything was
800 successfully parsed), will leave an OP for the substring scanned
801 in yylval. Caller must intuit reason for not parsing further
802 by looking at the next characters herself.
806 double-quoted style: \r and \n
807 regexp special ones: \D \s
809 backrefs: \1 (deprecated in substitution replacements)
810 case and quoting: \U \Q \E
811 stops on @ and $, but not for $ as tail anchor
814 characters are VERY literal, except for - not at the start or end
815 of the string, which indicates a range. scan_const expands the
816 range to the full set of intermediate characters.
818 In double-quoted strings:
820 double-quoted style: \r and \n
822 backrefs: \1 (deprecated)
823 case and quoting: \U \Q \E
826 scan_const does *not* construct ops to handle interpolated strings.
827 It stops processing as soon as it finds an embedded $ or @ variable
828 and leaves it to the caller to work out what's going on.
830 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
832 $ in pattern could be $foo or could be tail anchor. Assumption:
833 it's a tail anchor if $ is the last thing in the string, or if it's
834 followed by one of ")| \n\t"
836 \1 (backreferences) are turned into $1
838 The structure of the code is
839 while (there's a character to process) {
840 handle transliteration ranges
842 skip # initiated comments in //x patterns
843 check for embedded @foo
844 check for embedded scalars
846 leave intact backslashes from leave (below)
847 deprecate \1 in strings and sub replacements
848 handle string-changing backslashes \l \U \Q \E, etc.
849 switch (what was escaped) {
850 handle - in a transliteration (becomes a literal -)
851 handle \132 octal characters
852 handle 0x15 hex characters
853 handle \cV (control V)
854 handle printf backslashes (\f, \r, \n, etc)
857 } (end while character to read)
862 S_scan_const(pTHX_ char *start)
864 register char *send = PL_bufend; /* end of the constant */
865 SV *sv = NEWSV(93, send - start); /* sv for the constant */
866 register char *s = start; /* start of the constant */
867 register char *d = SvPVX(sv); /* destination for copies */
868 bool dorange = FALSE; /* are we in a translit range? */
870 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
871 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
873 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
874 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
877 /* leaveit is the set of acceptably-backslashed characters */
880 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
883 while (s < send || dorange) {
884 /* get transliterations out of the way (they're most literal) */
885 if (PL_lex_inwhat == OP_TRANS) {
886 /* expand a range A-Z to the full set of characters. AIE! */
888 I32 i; /* current expanded character */
889 I32 min; /* first character in range */
890 I32 max; /* last character in range */
892 i = d - SvPVX(sv); /* remember current offset */
893 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
894 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
895 d -= 2; /* eat the first char and the - */
897 min = (U8)*d; /* first char in range */
898 max = (U8)d[1]; /* last char in range */
901 if ((isLOWER(min) && isLOWER(max)) ||
902 (isUPPER(min) && isUPPER(max))) {
904 for (i = min; i <= max; i++)
908 for (i = min; i <= max; i++)
915 for (i = min; i <= max; i++)
918 /* mark the range as done, and continue */
923 /* range begins (ignore - as first or last char) */
924 else if (*s == '-' && s+1 < send && s != start) {
926 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
935 /* if we get here, we're not doing a transliteration */
937 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
938 except for the last char, which will be done separately. */
939 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
941 while (s < send && *s != ')')
943 } else if (s[2] == '{'
944 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
946 char *regparse = s + (s[2] == '{' ? 3 : 4);
949 while (count && (c = *regparse)) {
950 if (c == '\\' && regparse[1])
958 if (*regparse != ')') {
959 regparse--; /* Leave one char for continuation. */
960 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
967 /* likewise skip #-initiated comments in //x patterns */
968 else if (*s == '#' && PL_lex_inpat &&
969 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
970 while (s+1 < send && *s != '\n')
974 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
975 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
978 /* check for embedded scalars. only stop if we're sure it's a
981 else if (*s == '$') {
982 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
984 if (s + 1 < send && !strchr("()| \n\t", s[1]))
985 break; /* in regexp, $ might be tail anchor */
988 /* (now in tr/// code again) */
990 if (*s & 0x80 && thisutf) {
991 dTHR; /* only for ckWARN */
992 if (ckWARN(WARN_UTF8)) {
993 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1003 if (*s == '\\' && s+1 < send) {
1006 /* some backslashes we leave behind */
1007 if (*leaveit && *s && strchr(leaveit, *s)) {
1013 /* deprecate \1 in strings and substitution replacements */
1014 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1015 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1017 dTHR; /* only for ckWARN */
1018 if (ckWARN(WARN_SYNTAX))
1019 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1024 /* string-change backslash escapes */
1025 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1030 /* if we get here, it's either a quoted -, or a digit */
1033 /* quoted - in transliterations */
1035 if (PL_lex_inwhat == OP_TRANS) {
1043 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1044 Perl_warner(aTHX_ WARN_UNSAFE,
1045 "Unrecognized escape \\%c passed through",
1047 /* default action is to copy the quoted character */
1052 /* \132 indicates an octal constant */
1053 case '0': case '1': case '2': case '3':
1054 case '4': case '5': case '6': case '7':
1055 *d++ = scan_oct(s, 3, &len);
1059 /* \x24 indicates a hex constant */
1063 char* e = strchr(s, '}');
1066 yyerror("Missing right brace on \\x{}");
1071 if (ckWARN(WARN_UTF8))
1072 Perl_warner(aTHX_ WARN_UTF8,
1073 "Use of \\x{} without utf8 declaration");
1075 /* note: utf always shorter than hex */
1076 d = (char*)uv_to_utf8((U8*)d,
1077 scan_hex(s + 1, e - s - 1, &len));
1082 UV uv = (UV)scan_hex(s, 2, &len);
1083 if (utf && PL_lex_inwhat == OP_TRANS &&
1084 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1086 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1089 if (uv >= 127 && UTF) {
1091 if (ckWARN(WARN_UTF8))
1092 Perl_warner(aTHX_ WARN_UTF8,
1093 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1102 /* \c is a control character */
1116 /* printf-style backslashes, formfeeds, newlines, etc */
1134 *d++ = '\047'; /* CP 1047 */
1137 *d++ = '\057'; /* CP 1047 */
1151 } /* end if (backslash) */
1154 } /* while loop to process each character */
1156 /* terminate the string and set up the sv */
1158 SvCUR_set(sv, d - SvPVX(sv));
1161 /* shrink the sv if we allocated more than we used */
1162 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1163 SvLEN_set(sv, SvCUR(sv) + 1);
1164 Renew(SvPVX(sv), SvLEN(sv), char);
1167 /* return the substring (via yylval) only if we parsed anything */
1168 if (s > PL_bufptr) {
1169 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1170 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1172 ( PL_lex_inwhat == OP_TRANS
1174 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1177 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1183 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1185 S_intuit_more(pTHX_ register char *s)
1187 if (PL_lex_brackets)
1189 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1191 if (*s != '{' && *s != '[')
1196 /* In a pattern, so maybe we have {n,m}. */
1213 /* On the other hand, maybe we have a character class */
1216 if (*s == ']' || *s == '^')
1219 int weight = 2; /* let's weigh the evidence */
1221 unsigned char un_char = 255, last_un_char;
1222 char *send = strchr(s,']');
1223 char tmpbuf[sizeof PL_tokenbuf * 4];
1225 if (!send) /* has to be an expression */
1228 Zero(seen,256,char);
1231 else if (isDIGIT(*s)) {
1233 if (isDIGIT(s[1]) && s[2] == ']')
1239 for (; s < send; s++) {
1240 last_un_char = un_char;
1241 un_char = (unsigned char)*s;
1246 weight -= seen[un_char] * 10;
1247 if (isALNUM_lazy(s+1)) {
1248 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1249 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1254 else if (*s == '$' && s[1] &&
1255 strchr("[#!%*<>()-=",s[1])) {
1256 if (/*{*/ strchr("])} =",s[2]))
1265 if (strchr("wds]",s[1]))
1267 else if (seen['\''] || seen['"'])
1269 else if (strchr("rnftbxcav",s[1]))
1271 else if (isDIGIT(s[1])) {
1273 while (s[1] && isDIGIT(s[1]))
1283 if (strchr("aA01! ",last_un_char))
1285 if (strchr("zZ79~",s[1]))
1287 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1288 weight -= 5; /* cope with negative subscript */
1291 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1292 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1297 if (keyword(tmpbuf, d - tmpbuf))
1300 if (un_char == last_un_char + 1)
1302 weight -= seen[un_char];
1307 if (weight >= 0) /* probably a character class */
1315 S_intuit_method(pTHX_ char *start, GV *gv)
1317 char *s = start + (*start == '$');
1318 char tmpbuf[sizeof PL_tokenbuf];
1326 if ((cv = GvCVu(gv))) {
1327 char *proto = SvPVX(cv);
1337 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1338 if (*start == '$') {
1339 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1344 return *s == '(' ? FUNCMETH : METHOD;
1346 if (!keyword(tmpbuf, len)) {
1347 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1352 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1353 if (indirgv && GvCVu(indirgv))
1355 /* filehandle or package name makes it a method */
1356 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1358 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1359 return 0; /* no assumptions -- "=>" quotes bearword */
1361 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1362 newSVpvn(tmpbuf,len));
1363 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1367 return *s == '(' ? FUNCMETH : METHOD;
1377 char *pdb = PerlEnv_getenv("PERL5DB");
1381 SETERRNO(0,SS$_NORMAL);
1382 return "BEGIN { require 'perl5db.pl' }";
1388 /* Encoded script support. filter_add() effectively inserts a
1389 * 'pre-processing' function into the current source input stream.
1390 * Note that the filter function only applies to the current source file
1391 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1393 * The datasv parameter (which may be NULL) can be used to pass
1394 * private data to this instance of the filter. The filter function
1395 * can recover the SV using the FILTER_DATA macro and use it to
1396 * store private buffers and state information.
1398 * The supplied datasv parameter is upgraded to a PVIO type
1399 * and the IoDIRP field is used to store the function pointer.
1400 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1401 * private use must be set using malloc'd pointers.
1405 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1407 if (!funcp){ /* temporary handy debugging hack to be deleted */
1408 PL_filter_debug = atoi((char*)datasv);
1411 if (!PL_rsfp_filters)
1412 PL_rsfp_filters = newAV();
1414 datasv = NEWSV(255,0);
1415 if (!SvUPGRADE(datasv, SVt_PVIO))
1416 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1417 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1419 if (PL_filter_debug) {
1421 Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1423 #endif /* DEBUGGING */
1424 av_unshift(PL_rsfp_filters, 1);
1425 av_store(PL_rsfp_filters, 0, datasv) ;
1430 /* Delete most recently added instance of this filter function. */
1432 Perl_filter_del(pTHX_ filter_t funcp)
1435 if (PL_filter_debug)
1436 Perl_warn(aTHX_ "filter_del func %p", funcp);
1437 #endif /* DEBUGGING */
1438 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1440 /* if filter is on top of stack (usual case) just pop it off */
1441 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1442 IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1443 sv_free(av_pop(PL_rsfp_filters));
1447 /* we need to search for the correct entry and clear it */
1448 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1452 /* Invoke the n'th filter function for the current rsfp. */
1454 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1457 /* 0 = read one text line */
1462 if (!PL_rsfp_filters)
1464 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1465 /* Provide a default input filter to make life easy. */
1466 /* Note that we append to the line. This is handy. */
1468 if (PL_filter_debug)
1469 Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
1470 #endif /* DEBUGGING */
1474 int old_len = SvCUR(buf_sv) ;
1476 /* ensure buf_sv is large enough */
1477 SvGROW(buf_sv, old_len + maxlen) ;
1478 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1479 if (PerlIO_error(PL_rsfp))
1480 return -1; /* error */
1482 return 0 ; /* end of file */
1484 SvCUR_set(buf_sv, old_len + len) ;
1487 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1488 if (PerlIO_error(PL_rsfp))
1489 return -1; /* error */
1491 return 0 ; /* end of file */
1494 return SvCUR(buf_sv);
1496 /* Skip this filter slot if filter has been deleted */
1497 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1499 if (PL_filter_debug)
1500 Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
1501 #endif /* DEBUGGING */
1502 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1504 /* Get function pointer hidden within datasv */
1505 funcp = (filter_t)IoDIRP(datasv);
1507 if (PL_filter_debug) {
1509 Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
1510 idx, funcp, SvPV(datasv,n_a));
1512 #endif /* DEBUGGING */
1513 /* Call function. The function is expected to */
1514 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1515 /* Return: <0:error, =0:eof, >0:not eof */
1516 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1520 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1523 if (!PL_rsfp_filters) {
1524 filter_add(win32_textfilter,NULL);
1527 if (PL_rsfp_filters) {
1530 SvCUR_set(sv, 0); /* start with empty line */
1531 if (FILTER_READ(0, sv, 0) > 0)
1532 return ( SvPVX(sv) ) ;
1537 return (sv_gets(sv, fp, append));
1542 static char* exp_name[] =
1543 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1549 Works out what to call the token just pulled out of the input
1550 stream. The yacc parser takes care of taking the ops we return and
1551 stitching them into a tree.
1557 if read an identifier
1558 if we're in a my declaration
1559 croak if they tried to say my($foo::bar)
1560 build the ops for a my() declaration
1561 if it's an access to a my() variable
1562 are we in a sort block?
1563 croak if my($a); $a <=> $b
1564 build ops for access to a my() variable
1565 if in a dq string, and they've said @foo and we can't find @foo
1567 build ops for a bareword
1568 if we already built the token before, use it.
1572 #ifdef USE_PURE_BISON
1573 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1586 #ifdef USE_PURE_BISON
1587 yylval_pointer = lvalp;
1588 yychar_pointer = lcharp;
1591 /* check if there's an identifier for us to look at */
1592 if (PL_pending_ident) {
1593 /* pit holds the identifier we read and pending_ident is reset */
1594 char pit = PL_pending_ident;
1595 PL_pending_ident = 0;
1597 /* if we're in a my(), we can't allow dynamics here.
1598 $foo'bar has already been turned into $foo::bar, so
1599 just check for colons.
1601 if it's a legal name, the OP is a PADANY.
1604 if (strchr(PL_tokenbuf,':'))
1605 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1607 yylval.opval = newOP(OP_PADANY, 0);
1608 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1613 build the ops for accesses to a my() variable.
1615 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1616 then used in a comparison. This catches most, but not
1617 all cases. For instance, it catches
1618 sort { my($a); $a <=> $b }
1620 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1621 (although why you'd do that is anyone's guess).
1624 if (!strchr(PL_tokenbuf,':')) {
1626 /* Check for single character per-thread SVs */
1627 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1628 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1629 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1631 yylval.opval = newOP(OP_THREADSV, 0);
1632 yylval.opval->op_targ = tmp;
1635 #endif /* USE_THREADS */
1636 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1637 /* if it's a sort block and they're naming $a or $b */
1638 if (PL_last_lop_op == OP_SORT &&
1639 PL_tokenbuf[0] == '$' &&
1640 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1643 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1644 d < PL_bufend && *d != '\n';
1647 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1648 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
1654 yylval.opval = newOP(OP_PADANY, 0);
1655 yylval.opval->op_targ = tmp;
1661 Whine if they've said @foo in a doublequoted string,
1662 and @foo isn't a variable we can find in the symbol
1665 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1666 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1667 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1668 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
1669 PL_tokenbuf, PL_tokenbuf));
1672 /* build ops for a bareword */
1673 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1674 yylval.opval->op_private = OPpCONST_ENTERED;
1675 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1676 ((PL_tokenbuf[0] == '$') ? SVt_PV
1677 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1682 /* no identifier pending identification */
1684 switch (PL_lex_state) {
1686 case LEX_NORMAL: /* Some compilers will produce faster */
1687 case LEX_INTERPNORMAL: /* code if we comment these out. */
1691 /* when we're already built the next token, just pull it out the queue */
1694 yylval = PL_nextval[PL_nexttoke];
1696 PL_lex_state = PL_lex_defer;
1697 PL_expect = PL_lex_expect;
1698 PL_lex_defer = LEX_NORMAL;
1700 return(PL_nexttype[PL_nexttoke]);
1702 /* interpolated case modifiers like \L \U, including \Q and \E.
1703 when we get here, PL_bufptr is at the \
1705 case LEX_INTERPCASEMOD:
1707 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1708 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
1710 /* handle \E or end of string */
1711 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1715 if (PL_lex_casemods) {
1716 oldmod = PL_lex_casestack[--PL_lex_casemods];
1717 PL_lex_casestack[PL_lex_casemods] = '\0';
1719 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1721 PL_lex_state = LEX_INTERPCONCAT;
1725 if (PL_bufptr != PL_bufend)
1727 PL_lex_state = LEX_INTERPCONCAT;
1732 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1733 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1734 if (strchr("LU", *s) &&
1735 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1737 PL_lex_casestack[--PL_lex_casemods] = '\0';
1740 if (PL_lex_casemods > 10) {
1741 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1742 if (newlb != PL_lex_casestack) {
1744 PL_lex_casestack = newlb;
1747 PL_lex_casestack[PL_lex_casemods++] = *s;
1748 PL_lex_casestack[PL_lex_casemods] = '\0';
1749 PL_lex_state = LEX_INTERPCONCAT;
1750 PL_nextval[PL_nexttoke].ival = 0;
1753 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1755 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1757 PL_nextval[PL_nexttoke].ival = OP_LC;
1759 PL_nextval[PL_nexttoke].ival = OP_UC;
1761 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1763 Perl_croak(aTHX_ "panic: yylex");
1766 if (PL_lex_starts) {
1775 case LEX_INTERPPUSH:
1776 return sublex_push();
1778 case LEX_INTERPSTART:
1779 if (PL_bufptr == PL_bufend)
1780 return sublex_done();
1782 PL_lex_dojoin = (*PL_bufptr == '@');
1783 PL_lex_state = LEX_INTERPNORMAL;
1784 if (PL_lex_dojoin) {
1785 PL_nextval[PL_nexttoke].ival = 0;
1788 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1789 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1790 force_next(PRIVATEREF);
1792 force_ident("\"", '$');
1793 #endif /* USE_THREADS */
1794 PL_nextval[PL_nexttoke].ival = 0;
1796 PL_nextval[PL_nexttoke].ival = 0;
1798 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1801 if (PL_lex_starts++) {
1807 case LEX_INTERPENDMAYBE:
1808 if (intuit_more(PL_bufptr)) {
1809 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1815 if (PL_lex_dojoin) {
1816 PL_lex_dojoin = FALSE;
1817 PL_lex_state = LEX_INTERPCONCAT;
1820 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
1821 && SvEVALED(PL_lex_repl))
1823 if (PL_bufptr != PL_bufend)
1824 Perl_croak(aTHX_ "Bad evalled substitution pattern");
1825 PL_lex_repl = Nullsv;
1828 case LEX_INTERPCONCAT:
1830 if (PL_lex_brackets)
1831 Perl_croak(aTHX_ "panic: INTERPCONCAT");
1833 if (PL_bufptr == PL_bufend)
1834 return sublex_done();
1836 if (SvIVX(PL_linestr) == '\'') {
1837 SV *sv = newSVsv(PL_linestr);
1840 else if ( PL_hints & HINT_NEW_RE )
1841 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1842 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1846 s = scan_const(PL_bufptr);
1848 PL_lex_state = LEX_INTERPCASEMOD;
1850 PL_lex_state = LEX_INTERPSTART;
1853 if (s != PL_bufptr) {
1854 PL_nextval[PL_nexttoke] = yylval;
1857 if (PL_lex_starts++)
1867 PL_lex_state = LEX_NORMAL;
1868 s = scan_formline(PL_bufptr);
1869 if (!PL_lex_formbrack)
1875 PL_oldoldbufptr = PL_oldbufptr;
1878 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1884 if (isIDFIRST_lazy(s))
1886 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
1889 goto fake_eof; /* emulate EOF on ^D or ^Z */
1894 if (PL_lex_brackets)
1895 yyerror("Missing right curly or square bracket");
1898 if (s++ < PL_bufend)
1899 goto retry; /* ignore stray nulls */
1902 if (!PL_in_eval && !PL_preambled) {
1903 PL_preambled = TRUE;
1904 sv_setpv(PL_linestr,incl_perldb());
1905 if (SvCUR(PL_linestr))
1906 sv_catpv(PL_linestr,";");
1908 while(AvFILLp(PL_preambleav) >= 0) {
1909 SV *tmpsv = av_shift(PL_preambleav);
1910 sv_catsv(PL_linestr, tmpsv);
1911 sv_catpv(PL_linestr, ";");
1914 sv_free((SV*)PL_preambleav);
1915 PL_preambleav = NULL;
1917 if (PL_minus_n || PL_minus_p) {
1918 sv_catpv(PL_linestr, "LINE: while (<>) {");
1920 sv_catpv(PL_linestr,"chomp;");
1922 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1924 GvIMPORTED_AV_on(gv);
1926 if (strchr("/'\"", *PL_splitstr)
1927 && strchr(PL_splitstr + 1, *PL_splitstr))
1928 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
1931 s = "'~#\200\1'"; /* surely one char is unused...*/
1932 while (s[1] && strchr(PL_splitstr, *s)) s++;
1934 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
1935 "q" + (delim == '\''), delim);
1936 for (s = PL_splitstr; *s; s++) {
1938 sv_catpvn(PL_linestr, "\\", 1);
1939 sv_catpvn(PL_linestr, s, 1);
1941 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
1945 sv_catpv(PL_linestr,"@F=split(' ');");
1948 sv_catpv(PL_linestr, "\n");
1949 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1950 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1951 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1952 SV *sv = NEWSV(85,0);
1954 sv_upgrade(sv, SVt_PVMG);
1955 sv_setsv(sv,PL_linestr);
1956 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1961 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1964 if (PL_preprocess && !PL_in_eval)
1965 (void)PerlProc_pclose(PL_rsfp);
1966 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1967 PerlIO_clearerr(PL_rsfp);
1969 (void)PerlIO_close(PL_rsfp);
1971 PL_doextract = FALSE;
1973 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1974 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1975 sv_catpv(PL_linestr,";}");
1976 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1977 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1978 PL_minus_n = PL_minus_p = 0;
1981 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1982 sv_setpv(PL_linestr,"");
1983 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1986 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1987 PL_doextract = FALSE;
1989 /* Incest with pod. */
1990 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1991 sv_setpv(PL_linestr, "");
1992 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1993 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1994 PL_doextract = FALSE;
1998 } while (PL_doextract);
1999 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2000 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2001 SV *sv = NEWSV(85,0);
2003 sv_upgrade(sv, SVt_PVMG);
2004 sv_setsv(sv,PL_linestr);
2005 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2007 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2008 if (PL_curcop->cop_line == 1) {
2009 while (s < PL_bufend && isSPACE(*s))
2011 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2015 if (*s == '#' && *(s+1) == '!')
2017 #ifdef ALTERNATE_SHEBANG
2019 static char as[] = ALTERNATE_SHEBANG;
2020 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2021 d = s + (sizeof(as) - 1);
2023 #endif /* ALTERNATE_SHEBANG */
2032 while (*d && !isSPACE(*d))
2036 #ifdef ARG_ZERO_IS_SCRIPT
2037 if (ipathend > ipath) {
2039 * HP-UX (at least) sets argv[0] to the script name,
2040 * which makes $^X incorrect. And Digital UNIX and Linux,
2041 * at least, set argv[0] to the basename of the Perl
2042 * interpreter. So, having found "#!", we'll set it right.
2044 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2045 assert(SvPOK(x) || SvGMAGICAL(x));
2046 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2047 sv_setpvn(x, ipath, ipathend - ipath);
2050 TAINT_NOT; /* $^X is always tainted, but that's OK */
2052 #endif /* ARG_ZERO_IS_SCRIPT */
2057 d = instr(s,"perl -");
2059 d = instr(s,"perl");
2060 #ifdef ALTERNATE_SHEBANG
2062 * If the ALTERNATE_SHEBANG on this system starts with a
2063 * character that can be part of a Perl expression, then if
2064 * we see it but not "perl", we're probably looking at the
2065 * start of Perl code, not a request to hand off to some
2066 * other interpreter. Similarly, if "perl" is there, but
2067 * not in the first 'word' of the line, we assume the line
2068 * contains the start of the Perl program.
2070 if (d && *s != '#') {
2072 while (*c && !strchr("; \t\r\n\f\v#", *c))
2075 d = Nullch; /* "perl" not in first word; ignore */
2077 *s = '#'; /* Don't try to parse shebang line */
2079 #endif /* ALTERNATE_SHEBANG */
2084 !instr(s,"indir") &&
2085 instr(PL_origargv[0],"perl"))
2091 while (s < PL_bufend && isSPACE(*s))
2093 if (s < PL_bufend) {
2094 Newz(899,newargv,PL_origargc+3,char*);
2096 while (s < PL_bufend && !isSPACE(*s))
2099 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2102 newargv = PL_origargv;
2104 PerlProc_execv(ipath, newargv);
2105 Perl_croak(aTHX_ "Can't exec %s", ipath);
2108 U32 oldpdb = PL_perldb;
2109 bool oldn = PL_minus_n;
2110 bool oldp = PL_minus_p;
2112 while (*d && !isSPACE(*d)) d++;
2113 while (*d == ' ' || *d == '\t') d++;
2117 if (*d == 'M' || *d == 'm') {
2119 while (*d && !isSPACE(*d)) d++;
2120 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2123 d = moreswitches(d);
2125 if (PERLDB_LINE && !oldpdb ||
2126 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2127 /* if we have already added "LINE: while (<>) {",
2128 we must not do it again */
2130 sv_setpv(PL_linestr, "");
2131 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2132 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2133 PL_preambled = FALSE;
2135 (void)gv_fetchfile(PL_origfilename);
2142 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2144 PL_lex_state = LEX_FORMLINE;
2149 #ifdef PERL_STRICT_CR
2150 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2152 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2154 case ' ': case '\t': case '\f': case 013:
2159 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2161 while (s < d && *s != '\n')
2166 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2168 PL_lex_state = LEX_FORMLINE;
2178 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2183 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2186 if (strnEQ(s,"=>",2)) {
2187 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2188 OPERATOR('-'); /* unary minus */
2190 PL_last_uni = PL_oldbufptr;
2191 PL_last_lop_op = OP_FTEREAD; /* good enough */
2193 case 'r': FTST(OP_FTEREAD);
2194 case 'w': FTST(OP_FTEWRITE);
2195 case 'x': FTST(OP_FTEEXEC);
2196 case 'o': FTST(OP_FTEOWNED);
2197 case 'R': FTST(OP_FTRREAD);
2198 case 'W': FTST(OP_FTRWRITE);
2199 case 'X': FTST(OP_FTREXEC);
2200 case 'O': FTST(OP_FTROWNED);
2201 case 'e': FTST(OP_FTIS);
2202 case 'z': FTST(OP_FTZERO);
2203 case 's': FTST(OP_FTSIZE);
2204 case 'f': FTST(OP_FTFILE);
2205 case 'd': FTST(OP_FTDIR);
2206 case 'l': FTST(OP_FTLINK);
2207 case 'p': FTST(OP_FTPIPE);
2208 case 'S': FTST(OP_FTSOCK);
2209 case 'u': FTST(OP_FTSUID);
2210 case 'g': FTST(OP_FTSGID);
2211 case 'k': FTST(OP_FTSVTX);
2212 case 'b': FTST(OP_FTBLK);
2213 case 'c': FTST(OP_FTCHR);
2214 case 't': FTST(OP_FTTTY);
2215 case 'T': FTST(OP_FTTEXT);
2216 case 'B': FTST(OP_FTBINARY);
2217 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2218 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2219 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2221 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2228 if (PL_expect == XOPERATOR)
2233 else if (*s == '>') {
2236 if (isIDFIRST_lazy(s)) {
2237 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2245 if (PL_expect == XOPERATOR)
2248 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2250 OPERATOR('-'); /* unary minus */
2257 if (PL_expect == XOPERATOR)
2262 if (PL_expect == XOPERATOR)
2265 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2271 if (PL_expect != XOPERATOR) {
2272 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2273 PL_expect = XOPERATOR;
2274 force_ident(PL_tokenbuf, '*');
2287 if (PL_expect == XOPERATOR) {
2291 PL_tokenbuf[0] = '%';
2292 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2293 if (!PL_tokenbuf[1]) {
2295 yyerror("Final % should be \\% or %name");
2298 PL_pending_ident = '%';
2320 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2321 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2326 if (PL_curcop->cop_line < PL_copline)
2327 PL_copline = PL_curcop->cop_line;
2338 if (PL_lex_brackets <= 0)
2339 yyerror("Unmatched right square bracket");
2342 if (PL_lex_state == LEX_INTERPNORMAL) {
2343 if (PL_lex_brackets == 0) {
2344 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2345 PL_lex_state = LEX_INTERPEND;
2352 if (PL_lex_brackets > 100) {
2353 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2354 if (newlb != PL_lex_brackstack) {
2356 PL_lex_brackstack = newlb;
2359 switch (PL_expect) {
2361 if (PL_lex_formbrack) {
2365 if (PL_oldoldbufptr == PL_last_lop)
2366 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2368 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2369 OPERATOR(HASHBRACK);
2371 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2374 PL_tokenbuf[0] = '\0';
2375 if (d < PL_bufend && *d == '-') {
2376 PL_tokenbuf[0] = '-';
2378 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2381 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2382 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2384 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2387 char minus = (PL_tokenbuf[0] == '-');
2388 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2395 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2399 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2404 if (PL_oldoldbufptr == PL_last_lop)
2405 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2407 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2410 OPERATOR(HASHBRACK);
2411 /* This hack serves to disambiguate a pair of curlies
2412 * as being a block or an anon hash. Normally, expectation
2413 * determines that, but in cases where we're not in a
2414 * position to expect anything in particular (like inside
2415 * eval"") we have to resolve the ambiguity. This code
2416 * covers the case where the first term in the curlies is a
2417 * quoted string. Most other cases need to be explicitly
2418 * disambiguated by prepending a `+' before the opening
2419 * curly in order to force resolution as an anon hash.
2421 * XXX should probably propagate the outer expectation
2422 * into eval"" to rely less on this hack, but that could
2423 * potentially break current behavior of eval"".
2427 if (*s == '\'' || *s == '"' || *s == '`') {
2428 /* common case: get past first string, handling escapes */
2429 for (t++; t < PL_bufend && *t != *s;)
2430 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2434 else if (*s == 'q') {
2437 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2438 && !isALNUM(*t)))) {
2440 char open, close, term;
2443 while (t < PL_bufend && isSPACE(*t))
2447 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2451 for (t++; t < PL_bufend; t++) {
2452 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2454 else if (*t == open)
2458 for (t++; t < PL_bufend; t++) {
2459 if (*t == '\\' && t+1 < PL_bufend)
2461 else if (*t == close && --brackets <= 0)
2463 else if (*t == open)
2469 else if (isIDFIRST_lazy(s)) {
2470 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2472 while (t < PL_bufend && isSPACE(*t))
2474 /* if comma follows first term, call it an anon hash */
2475 /* XXX it could be a comma expression with loop modifiers */
2476 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2477 || (*t == '=' && t[1] == '>')))
2478 OPERATOR(HASHBRACK);
2479 if (PL_expect == XREF)
2480 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2482 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2488 yylval.ival = PL_curcop->cop_line;
2489 if (isSPACE(*s) || *s == '#')
2490 PL_copline = NOLINE; /* invalidate current command line number */
2495 if (PL_lex_brackets <= 0)
2496 yyerror("Unmatched right curly bracket");
2498 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2499 if (PL_lex_brackets < PL_lex_formbrack)
2500 PL_lex_formbrack = 0;
2501 if (PL_lex_state == LEX_INTERPNORMAL) {
2502 if (PL_lex_brackets == 0) {
2503 if (PL_lex_fakebrack) {
2504 PL_lex_state = LEX_INTERPEND;
2506 return yylex(); /* ignore fake brackets */
2508 if (*s == '-' && s[1] == '>')
2509 PL_lex_state = LEX_INTERPENDMAYBE;
2510 else if (*s != '[' && *s != '{')
2511 PL_lex_state = LEX_INTERPEND;
2514 if (PL_lex_brackets < PL_lex_fakebrack) {
2516 PL_lex_fakebrack = 0;
2517 return yylex(); /* ignore fake brackets */
2527 if (PL_expect == XOPERATOR) {
2528 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2529 PL_curcop->cop_line--;
2530 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
2531 PL_curcop->cop_line++;
2536 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2538 PL_expect = XOPERATOR;
2539 force_ident(PL_tokenbuf, '&');
2543 yylval.ival = (OPpENTERSUB_AMPER<<8);
2562 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2563 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2565 if (PL_expect == XSTATE && isALPHA(tmp) &&
2566 (s == PL_linestart+1 || s[-2] == '\n') )
2568 if (PL_in_eval && !PL_rsfp) {
2573 if (strnEQ(s,"=cut",4)) {
2587 PL_doextract = TRUE;
2590 if (PL_lex_brackets < PL_lex_formbrack) {
2592 #ifdef PERL_STRICT_CR
2593 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2595 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2597 if (*t == '\n' || *t == '#') {
2615 if (PL_expect != XOPERATOR) {
2616 if (s[1] != '<' && !strchr(s,'>'))
2619 s = scan_heredoc(s);
2621 s = scan_inputsymbol(s);
2622 TERM(sublex_start());
2627 SHop(OP_LEFT_SHIFT);
2641 SHop(OP_RIGHT_SHIFT);
2650 if (PL_expect == XOPERATOR) {
2651 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2654 return ','; /* grandfather non-comma-format format */
2658 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2659 if (PL_expect == XOPERATOR)
2660 no_op("Array length", PL_bufptr);
2661 PL_tokenbuf[0] = '@';
2662 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2664 if (!PL_tokenbuf[1])
2666 PL_expect = XOPERATOR;
2667 PL_pending_ident = '#';
2671 if (PL_expect == XOPERATOR)
2672 no_op("Scalar", PL_bufptr);
2673 PL_tokenbuf[0] = '$';
2674 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2675 if (!PL_tokenbuf[1]) {
2677 yyerror("Final $ should be \\$ or $name");
2681 /* This kludge not intended to be bulletproof. */
2682 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2683 yylval.opval = newSVOP(OP_CONST, 0,
2684 newSViv((IV)PL_compiling.cop_arybase));
2685 yylval.opval->op_private = OPpCONST_ARYBASE;
2691 if (PL_lex_state == LEX_NORMAL)
2694 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2697 PL_tokenbuf[0] = '@';
2698 if (ckWARN(WARN_SYNTAX)) {
2700 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2703 PL_bufptr = skipspace(PL_bufptr);
2704 while (t < PL_bufend && *t != ']')
2706 Perl_warner(aTHX_ WARN_SYNTAX,
2707 "Multidimensional syntax %.*s not supported",
2708 (t - PL_bufptr) + 1, PL_bufptr);
2712 else if (*s == '{') {
2713 PL_tokenbuf[0] = '%';
2714 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2715 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2717 char tmpbuf[sizeof PL_tokenbuf];
2719 for (t++; isSPACE(*t); t++) ;
2720 if (isIDFIRST_lazy(t)) {
2721 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2722 for (; isSPACE(*t); t++) ;
2723 if (*t == ';' && get_cv(tmpbuf, FALSE))
2724 Perl_warner(aTHX_ WARN_SYNTAX,
2725 "You need to quote \"%s\"", tmpbuf);
2731 PL_expect = XOPERATOR;
2732 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
2733 bool islop = (PL_last_lop == PL_oldoldbufptr);
2734 if (!islop || PL_last_lop_op == OP_GREPSTART)
2735 PL_expect = XOPERATOR;
2736 else if (strchr("$@\"'`q", *s))
2737 PL_expect = XTERM; /* e.g. print $fh "foo" */
2738 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2739 PL_expect = XTERM; /* e.g. print $fh &sub */
2740 else if (isIDFIRST_lazy(s)) {
2741 char tmpbuf[sizeof PL_tokenbuf];
2742 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2743 if (tmp = keyword(tmpbuf, len)) {
2744 /* binary operators exclude handle interpretations */
2756 PL_expect = XTERM; /* e.g. print $fh length() */
2761 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2762 if (gv && GvCVu(gv))
2763 PL_expect = XTERM; /* e.g. print $fh subr() */
2766 else if (isDIGIT(*s))
2767 PL_expect = XTERM; /* e.g. print $fh 3 */
2768 else if (*s == '.' && isDIGIT(s[1]))
2769 PL_expect = XTERM; /* e.g. print $fh .3 */
2770 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2771 PL_expect = XTERM; /* e.g. print $fh -1 */
2772 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2773 PL_expect = XTERM; /* print $fh <<"EOF" */
2775 PL_pending_ident = '$';
2779 if (PL_expect == XOPERATOR)
2781 PL_tokenbuf[0] = '@';
2782 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2783 if (!PL_tokenbuf[1]) {
2785 yyerror("Final @ should be \\@ or @name");
2788 if (PL_lex_state == LEX_NORMAL)
2790 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2792 PL_tokenbuf[0] = '%';
2794 /* Warn about @ where they meant $. */
2795 if (ckWARN(WARN_SYNTAX)) {
2796 if (*s == '[' || *s == '{') {
2798 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2800 if (*t == '}' || *t == ']') {
2802 PL_bufptr = skipspace(PL_bufptr);
2803 Perl_warner(aTHX_ WARN_SYNTAX,
2804 "Scalar value %.*s better written as $%.*s",
2805 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2810 PL_pending_ident = '@';
2813 case '/': /* may either be division or pattern */
2814 case '?': /* may either be conditional or pattern */
2815 if (PL_expect != XOPERATOR) {
2816 /* Disable warning on "study /blah/" */
2817 if (PL_oldoldbufptr == PL_last_uni
2818 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2819 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2821 s = scan_pat(s,OP_MATCH);
2822 TERM(sublex_start());
2830 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2831 #ifdef PERL_STRICT_CR
2834 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2836 && (s == PL_linestart || s[-1] == '\n') )
2838 PL_lex_formbrack = 0;
2842 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2848 yylval.ival = OPf_SPECIAL;
2854 if (PL_expect != XOPERATOR)
2859 case '0': case '1': case '2': case '3': case '4':
2860 case '5': case '6': case '7': case '8': case '9':
2862 if (PL_expect == XOPERATOR)
2868 if (PL_expect == XOPERATOR) {
2869 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2872 return ','; /* grandfather non-comma-format format */
2878 missingterm((char*)0);
2879 yylval.ival = OP_CONST;
2880 TERM(sublex_start());
2884 if (PL_expect == XOPERATOR) {
2885 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2888 return ','; /* grandfather non-comma-format format */
2894 missingterm((char*)0);
2895 yylval.ival = OP_CONST;
2896 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2897 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2898 yylval.ival = OP_STRINGIFY;
2902 TERM(sublex_start());
2906 if (PL_expect == XOPERATOR)
2907 no_op("Backticks",s);
2909 missingterm((char*)0);
2910 yylval.ival = OP_BACKTICK;
2912 TERM(sublex_start());
2916 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2917 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2919 if (PL_expect == XOPERATOR)
2920 no_op("Backslash",s);
2924 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2964 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2966 /* Some keywords can be followed by any delimiter, including ':' */
2967 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2968 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2969 (PL_tokenbuf[0] == 'q' &&
2970 strchr("qwxr", PL_tokenbuf[1]))));
2972 /* x::* is just a word, unless x is "CORE" */
2973 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2977 while (d < PL_bufend && isSPACE(*d))
2978 d++; /* no comments skipped here, or s### is misparsed */
2980 /* Is this a label? */
2981 if (!tmp && PL_expect == XSTATE
2982 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2984 yylval.pval = savepv(PL_tokenbuf);
2989 /* Check for keywords */
2990 tmp = keyword(PL_tokenbuf, len);
2992 /* Is this a word before a => operator? */
2993 if (strnEQ(d,"=>",2)) {
2995 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2996 yylval.opval->op_private = OPpCONST_BARE;
3000 if (tmp < 0) { /* second-class keyword? */
3001 GV *ogv = Nullgv; /* override (winner) */
3002 GV *hgv = Nullgv; /* hidden (loser) */
3003 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3005 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3008 if (GvIMPORTED_CV(gv))
3010 else if (! CvMETHOD(cv))
3014 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3015 (gv = *gvp) != (GV*)&PL_sv_undef &&
3016 GvCVu(gv) && GvIMPORTED_CV(gv))
3022 tmp = 0; /* overridden by import or by GLOBAL */
3025 && -tmp==KEY_lock /* XXX generalizable kludge */
3026 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3028 tmp = 0; /* any sub overrides "weak" keyword */
3030 else { /* no override */
3034 if (ckWARN(WARN_AMBIGUOUS) && hgv
3035 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3036 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3037 "Ambiguous call resolved as CORE::%s(), %s",
3038 GvENAME(hgv), "qualify as such or use &");
3045 default: /* not a keyword */
3048 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3050 /* Get the rest if it looks like a package qualifier */
3052 if (*s == '\'' || *s == ':' && s[1] == ':') {
3054 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3057 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3058 *s == '\'' ? "'" : "::");
3062 if (PL_expect == XOPERATOR) {
3063 if (PL_bufptr == PL_linestart) {
3064 PL_curcop->cop_line--;
3065 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3066 PL_curcop->cop_line++;
3069 no_op("Bareword",s);
3072 /* Look for a subroutine with this name in current package,
3073 unless name is "Foo::", in which case Foo is a bearword
3074 (and a package name). */
3077 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3079 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3080 Perl_warner(aTHX_ WARN_UNSAFE,
3081 "Bareword \"%s\" refers to nonexistent package",
3084 PL_tokenbuf[len] = '\0';
3091 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3094 /* if we saw a global override before, get the right name */
3097 sv = newSVpvn("CORE::GLOBAL::",14);
3098 sv_catpv(sv,PL_tokenbuf);
3101 sv = newSVpv(PL_tokenbuf,0);
3103 /* Presume this is going to be a bareword of some sort. */
3106 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3107 yylval.opval->op_private = OPpCONST_BARE;
3109 /* And if "Foo::", then that's what it certainly is. */
3114 /* See if it's the indirect object for a list operator. */
3116 if (PL_oldoldbufptr &&
3117 PL_oldoldbufptr < PL_bufptr &&
3118 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3119 /* NO SKIPSPACE BEFORE HERE! */
3120 (PL_expect == XREF ||
3121 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3123 bool immediate_paren = *s == '(';
3125 /* (Now we can afford to cross potential line boundary.) */
3128 /* Two barewords in a row may indicate method call. */
3130 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3133 /* If not a declared subroutine, it's an indirect object. */
3134 /* (But it's an indir obj regardless for sort.) */
3136 if ((PL_last_lop_op == OP_SORT ||
3137 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3138 (PL_last_lop_op != OP_MAPSTART &&
3139 PL_last_lop_op != OP_GREPSTART))
3141 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3146 /* If followed by a paren, it's certainly a subroutine. */
3148 PL_expect = XOPERATOR;
3152 if (gv && GvCVu(gv)) {
3153 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3154 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3159 PL_nextval[PL_nexttoke].opval = yylval.opval;
3160 PL_expect = XOPERATOR;
3166 /* If followed by var or block, call it a method (unless sub) */
3168 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3169 PL_last_lop = PL_oldbufptr;
3170 PL_last_lop_op = OP_METHOD;
3174 /* If followed by a bareword, see if it looks like indir obj. */
3176 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3179 /* Not a method, so call it a subroutine (if defined) */
3181 if (gv && GvCVu(gv)) {
3183 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3184 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3185 "Ambiguous use of -%s resolved as -&%s()",
3186 PL_tokenbuf, PL_tokenbuf);
3187 /* Check for a constant sub */
3189 if ((sv = cv_const_sv(cv))) {
3191 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3192 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3193 yylval.opval->op_private = 0;
3197 /* Resolve to GV now. */
3198 op_free(yylval.opval);
3199 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3200 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3201 PL_last_lop = PL_oldbufptr;
3202 PL_last_lop_op = OP_ENTERSUB;
3203 /* Is there a prototype? */
3206 char *proto = SvPV((SV*)cv, len);
3209 if (strEQ(proto, "$"))
3211 if (*proto == '&' && *s == '{') {
3212 sv_setpv(PL_subname,"__ANON__");
3216 PL_nextval[PL_nexttoke].opval = yylval.opval;
3222 /* Call it a bare word */
3224 if (PL_hints & HINT_STRICT_SUBS)
3225 yylval.opval->op_private |= OPpCONST_STRICT;
3228 if (ckWARN(WARN_RESERVED)) {
3229 if (lastchar != '-') {
3230 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3232 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3239 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3240 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3241 "Operator or semicolon missing before %c%s",
3242 lastchar, PL_tokenbuf);
3243 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3244 "Ambiguous use of %c resolved as operator %c",
3245 lastchar, lastchar);
3251 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3252 newSVsv(GvSV(PL_curcop->cop_filegv)));
3256 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3257 Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3260 case KEY___PACKAGE__:
3261 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3263 ? newSVsv(PL_curstname)
3272 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3273 char *pname = "main";
3274 if (PL_tokenbuf[2] == 'D')
3275 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3276 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3279 GvIOp(gv) = newIO();
3280 IoIFP(GvIOp(gv)) = PL_rsfp;
3281 #if defined(HAS_FCNTL) && defined(F_SETFD)
3283 int fd = PerlIO_fileno(PL_rsfp);
3284 fcntl(fd,F_SETFD,fd >= 3);
3287 /* Mark this internal pseudo-handle as clean */
3288 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3290 IoTYPE(GvIOp(gv)) = '|';
3291 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3292 IoTYPE(GvIOp(gv)) = '-';
3294 IoTYPE(GvIOp(gv)) = '<';
3305 if (PL_expect == XSTATE) {
3312 if (*s == ':' && s[1] == ':') {
3315 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3316 tmp = keyword(PL_tokenbuf, len);
3330 LOP(OP_ACCEPT,XTERM);
3336 LOP(OP_ATAN2,XTERM);
3345 LOP(OP_BLESS,XTERM);
3354 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3371 if (!PL_cryptseen++)
3374 LOP(OP_CRYPT,XTERM);
3377 if (ckWARN(WARN_OCTAL)) {
3378 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3379 if (*d != '0' && isDIGIT(*d))
3380 yywarn("chmod: mode argument is missing initial 0");
3382 LOP(OP_CHMOD,XTERM);
3385 LOP(OP_CHOWN,XTERM);
3388 LOP(OP_CONNECT,XTERM);
3404 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3408 PL_hints |= HINT_BLOCK_SCOPE;
3418 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3419 LOP(OP_DBMOPEN,XTERM);
3425 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3432 yylval.ival = PL_curcop->cop_line;
3446 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3447 UNIBRACK(OP_ENTEREVAL);
3462 case KEY_endhostent:
3468 case KEY_endservent:
3471 case KEY_endprotoent:
3482 yylval.ival = PL_curcop->cop_line;
3484 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3486 if ((PL_bufend - p) >= 3 &&
3487 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3490 if (isIDFIRST_lazy(p))
3491 Perl_croak(aTHX_ "Missing $ on loop variable");
3496 LOP(OP_FORMLINE,XTERM);
3502 LOP(OP_FCNTL,XTERM);
3508 LOP(OP_FLOCK,XTERM);
3517 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3520 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3535 case KEY_getpriority:
3536 LOP(OP_GETPRIORITY,XTERM);
3538 case KEY_getprotobyname:
3541 case KEY_getprotobynumber:
3542 LOP(OP_GPBYNUMBER,XTERM);
3544 case KEY_getprotoent:
3556 case KEY_getpeername:
3557 UNI(OP_GETPEERNAME);
3559 case KEY_gethostbyname:
3562 case KEY_gethostbyaddr:
3563 LOP(OP_GHBYADDR,XTERM);
3565 case KEY_gethostent:
3568 case KEY_getnetbyname:
3571 case KEY_getnetbyaddr:
3572 LOP(OP_GNBYADDR,XTERM);
3577 case KEY_getservbyname:
3578 LOP(OP_GSBYNAME,XTERM);
3580 case KEY_getservbyport:
3581 LOP(OP_GSBYPORT,XTERM);
3583 case KEY_getservent:
3586 case KEY_getsockname:
3587 UNI(OP_GETSOCKNAME);
3589 case KEY_getsockopt:
3590 LOP(OP_GSOCKOPT,XTERM);
3612 yylval.ival = PL_curcop->cop_line;
3616 LOP(OP_INDEX,XTERM);
3622 LOP(OP_IOCTL,XTERM);
3634 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3665 LOP(OP_LISTEN,XTERM);
3674 s = scan_pat(s,OP_MATCH);
3675 TERM(sublex_start());
3678 LOP(OP_MAPSTART, XREF);
3681 LOP(OP_MKDIR,XTERM);
3684 LOP(OP_MSGCTL,XTERM);
3687 LOP(OP_MSGGET,XTERM);
3690 LOP(OP_MSGRCV,XTERM);
3693 LOP(OP_MSGSND,XTERM);
3698 if (isIDFIRST_lazy(s)) {
3699 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3700 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3701 if (!PL_in_my_stash) {
3704 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3711 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3718 if (PL_expect != XSTATE)
3719 yyerror("\"no\" not allowed in expression");
3720 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3721 s = force_version(s);
3730 if (isIDFIRST_lazy(s)) {
3732 for (d = s; isALNUM_lazy(d); d++) ;
3734 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
3735 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3736 "Precedence problem: open %.*s should be open(%.*s)",
3742 yylval.ival = OP_OR;
3752 LOP(OP_OPEN_DIR,XTERM);
3755 checkcomma(s,PL_tokenbuf,"filehandle");
3759 checkcomma(s,PL_tokenbuf,"filehandle");
3778 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3782 LOP(OP_PIPE_OP,XTERM);
3787 missingterm((char*)0);
3788 yylval.ival = OP_CONST;
3789 TERM(sublex_start());
3797 missingterm((char*)0);
3799 if (SvCUR(PL_lex_stuff)) {
3802 d = SvPV_force(PL_lex_stuff, len);
3804 for (; isSPACE(*d) && len; --len, ++d) ;
3807 if (!warned && ckWARN(WARN_SYNTAX)) {
3808 for (; !isSPACE(*d) && len; --len, ++d) {
3810 Perl_warner(aTHX_ WARN_SYNTAX,
3811 "Possible attempt to separate words with commas");
3814 else if (*d == '#') {
3815 Perl_warner(aTHX_ WARN_SYNTAX,
3816 "Possible attempt to put comments in qw() list");
3822 for (; !isSPACE(*d) && len; --len, ++d) ;
3824 words = append_elem(OP_LIST, words,
3825 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
3829 PL_nextval[PL_nexttoke].opval = words;
3834 SvREFCNT_dec(PL_lex_stuff);
3835 PL_lex_stuff = Nullsv;
3842 missingterm((char*)0);
3843 yylval.ival = OP_STRINGIFY;
3844 if (SvIVX(PL_lex_stuff) == '\'')
3845 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3846 TERM(sublex_start());
3849 s = scan_pat(s,OP_QR);
3850 TERM(sublex_start());
3855 missingterm((char*)0);
3856 yylval.ival = OP_BACKTICK;
3858 TERM(sublex_start());
3864 *PL_tokenbuf = '\0';
3865 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3866 if (isIDFIRST_lazy(PL_tokenbuf))
3867 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3869 yyerror("<> should be quotes");
3876 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3880 LOP(OP_RENAME,XTERM);
3889 LOP(OP_RINDEX,XTERM);
3912 LOP(OP_REVERSE,XTERM);
3923 TERM(sublex_start());
3925 TOKEN(1); /* force error */
3934 LOP(OP_SELECT,XTERM);
3940 LOP(OP_SEMCTL,XTERM);
3943 LOP(OP_SEMGET,XTERM);
3946 LOP(OP_SEMOP,XTERM);
3952 LOP(OP_SETPGRP,XTERM);
3954 case KEY_setpriority:
3955 LOP(OP_SETPRIORITY,XTERM);
3957 case KEY_sethostent:
3963 case KEY_setservent:
3966 case KEY_setprotoent:
3976 LOP(OP_SEEKDIR,XTERM);
3978 case KEY_setsockopt:
3979 LOP(OP_SSOCKOPT,XTERM);
3985 LOP(OP_SHMCTL,XTERM);
3988 LOP(OP_SHMGET,XTERM);
3991 LOP(OP_SHMREAD,XTERM);
3994 LOP(OP_SHMWRITE,XTERM);
3997 LOP(OP_SHUTDOWN,XTERM);
4006 LOP(OP_SOCKET,XTERM);
4008 case KEY_socketpair:
4009 LOP(OP_SOCKPAIR,XTERM);
4012 checkcomma(s,PL_tokenbuf,"subroutine name");
4014 if (*s == ';' || *s == ')') /* probably a close */
4015 Perl_croak(aTHX_ "sort is now a reserved word");
4017 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4021 LOP(OP_SPLIT,XTERM);
4024 LOP(OP_SPRINTF,XTERM);
4027 LOP(OP_SPLICE,XTERM);
4043 LOP(OP_SUBSTR,XTERM);
4050 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4051 char tmpbuf[sizeof PL_tokenbuf];
4053 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4054 if (strchr(tmpbuf, ':'))
4055 sv_setpv(PL_subname, tmpbuf);
4057 sv_setsv(PL_subname,PL_curstname);
4058 sv_catpvn(PL_subname,"::",2);
4059 sv_catpvn(PL_subname,tmpbuf,len);
4061 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4065 PL_expect = XTERMBLOCK;
4066 sv_setpv(PL_subname,"?");
4069 if (tmp == KEY_format) {
4072 PL_lex_formbrack = PL_lex_brackets + 1;
4076 /* Look for a prototype */
4083 SvREFCNT_dec(PL_lex_stuff);
4084 PL_lex_stuff = Nullsv;
4085 Perl_croak(aTHX_ "Prototype not terminated");
4088 d = SvPVX(PL_lex_stuff);
4090 for (p = d; *p; ++p) {
4095 SvCUR(PL_lex_stuff) = tmp;
4098 PL_nextval[1] = PL_nextval[0];
4099 PL_nexttype[1] = PL_nexttype[0];
4100 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4101 PL_nexttype[0] = THING;
4102 if (PL_nexttoke == 1) {
4103 PL_lex_defer = PL_lex_state;
4104 PL_lex_expect = PL_expect;
4105 PL_lex_state = LEX_KNOWNEXT;
4107 PL_lex_stuff = Nullsv;
4110 if (*SvPV(PL_subname,n_a) == '?') {
4111 sv_setpv(PL_subname,"__ANON__");
4118 LOP(OP_SYSTEM,XREF);
4121 LOP(OP_SYMLINK,XTERM);
4124 LOP(OP_SYSCALL,XTERM);
4127 LOP(OP_SYSOPEN,XTERM);
4130 LOP(OP_SYSSEEK,XTERM);
4133 LOP(OP_SYSREAD,XTERM);
4136 LOP(OP_SYSWRITE,XTERM);
4140 TERM(sublex_start());
4161 LOP(OP_TRUNCATE,XTERM);
4173 yylval.ival = PL_curcop->cop_line;
4177 yylval.ival = PL_curcop->cop_line;
4181 LOP(OP_UNLINK,XTERM);
4187 LOP(OP_UNPACK,XTERM);
4190 LOP(OP_UTIME,XTERM);
4193 if (ckWARN(WARN_OCTAL)) {
4194 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4195 if (*d != '0' && isDIGIT(*d))
4196 yywarn("umask: argument is missing initial 0");
4201 LOP(OP_UNSHIFT,XTERM);
4204 if (PL_expect != XSTATE)
4205 yyerror("\"use\" not allowed in expression");
4208 s = force_version(s);
4209 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4210 PL_nextval[PL_nexttoke].opval = Nullop;
4215 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4216 s = force_version(s);
4229 yylval.ival = PL_curcop->cop_line;
4233 PL_hints |= HINT_BLOCK_SCOPE;
4240 LOP(OP_WAITPID,XTERM);
4248 static char ctl_l[2];
4250 if (ctl_l[0] == '\0')
4251 ctl_l[0] = toCTRL('L');
4252 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4255 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4260 if (PL_expect == XOPERATOR)
4266 yylval.ival = OP_XOR;
4271 TERM(sublex_start());
4277 Perl_keyword(pTHX_ register char *d, I32 len)
4282 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4283 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4284 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4285 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4286 if (strEQ(d,"__END__")) return KEY___END__;
4290 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4295 if (strEQ(d,"and")) return -KEY_and;
4296 if (strEQ(d,"abs")) return -KEY_abs;
4299 if (strEQ(d,"alarm")) return -KEY_alarm;
4300 if (strEQ(d,"atan2")) return -KEY_atan2;
4303 if (strEQ(d,"accept")) return -KEY_accept;
4308 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4311 if (strEQ(d,"bless")) return -KEY_bless;
4312 if (strEQ(d,"bind")) return -KEY_bind;
4313 if (strEQ(d,"binmode")) return -KEY_binmode;
4316 if (strEQ(d,"CORE")) return -KEY_CORE;
4321 if (strEQ(d,"cmp")) return -KEY_cmp;
4322 if (strEQ(d,"chr")) return -KEY_chr;
4323 if (strEQ(d,"cos")) return -KEY_cos;
4326 if (strEQ(d,"chop")) return KEY_chop;
4329 if (strEQ(d,"close")) return -KEY_close;
4330 if (strEQ(d,"chdir")) return -KEY_chdir;
4331 if (strEQ(d,"chomp")) return KEY_chomp;
4332 if (strEQ(d,"chmod")) return -KEY_chmod;
4333 if (strEQ(d,"chown")) return -KEY_chown;
4334 if (strEQ(d,"crypt")) return -KEY_crypt;
4337 if (strEQ(d,"chroot")) return -KEY_chroot;
4338 if (strEQ(d,"caller")) return -KEY_caller;
4341 if (strEQ(d,"connect")) return -KEY_connect;
4344 if (strEQ(d,"closedir")) return -KEY_closedir;
4345 if (strEQ(d,"continue")) return -KEY_continue;
4350 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4355 if (strEQ(d,"do")) return KEY_do;
4358 if (strEQ(d,"die")) return -KEY_die;
4361 if (strEQ(d,"dump")) return -KEY_dump;
4364 if (strEQ(d,"delete")) return KEY_delete;
4367 if (strEQ(d,"defined")) return KEY_defined;
4368 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4371 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4376 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4377 if (strEQ(d,"END")) return KEY_END;
4382 if (strEQ(d,"eq")) return -KEY_eq;
4385 if (strEQ(d,"eof")) return -KEY_eof;
4386 if (strEQ(d,"exp")) return -KEY_exp;
4389 if (strEQ(d,"else")) return KEY_else;
4390 if (strEQ(d,"exit")) return -KEY_exit;
4391 if (strEQ(d,"eval")) return KEY_eval;
4392 if (strEQ(d,"exec")) return -KEY_exec;
4393 if (strEQ(d,"each")) return KEY_each;
4396 if (strEQ(d,"elsif")) return KEY_elsif;
4399 if (strEQ(d,"exists")) return KEY_exists;
4400 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4403 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4404 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4407 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4410 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4411 if (strEQ(d,"endservent")) return -KEY_endservent;
4414 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4421 if (strEQ(d,"for")) return KEY_for;
4424 if (strEQ(d,"fork")) return -KEY_fork;
4427 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4428 if (strEQ(d,"flock")) return -KEY_flock;
4431 if (strEQ(d,"format")) return KEY_format;
4432 if (strEQ(d,"fileno")) return -KEY_fileno;
4435 if (strEQ(d,"foreach")) return KEY_foreach;
4438 if (strEQ(d,"formline")) return -KEY_formline;
4444 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4445 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4449 if (strnEQ(d,"get",3)) {
4454 if (strEQ(d,"ppid")) return -KEY_getppid;
4455 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4458 if (strEQ(d,"pwent")) return -KEY_getpwent;
4459 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4460 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4463 if (strEQ(d,"peername")) return -KEY_getpeername;
4464 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4465 if (strEQ(d,"priority")) return -KEY_getpriority;
4468 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4471 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4475 else if (*d == 'h') {
4476 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4477 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4478 if (strEQ(d,"hostent")) return -KEY_gethostent;
4480 else if (*d == 'n') {
4481 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4482 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4483 if (strEQ(d,"netent")) return -KEY_getnetent;
4485 else if (*d == 's') {
4486 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4487 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4488 if (strEQ(d,"servent")) return -KEY_getservent;
4489 if (strEQ(d,"sockname")) return -KEY_getsockname;
4490 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4492 else if (*d == 'g') {
4493 if (strEQ(d,"grent")) return -KEY_getgrent;
4494 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4495 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4497 else if (*d == 'l') {
4498 if (strEQ(d,"login")) return -KEY_getlogin;
4500 else if (strEQ(d,"c")) return -KEY_getc;
4505 if (strEQ(d,"gt")) return -KEY_gt;
4506 if (strEQ(d,"ge")) return -KEY_ge;
4509 if (strEQ(d,"grep")) return KEY_grep;
4510 if (strEQ(d,"goto")) return KEY_goto;
4511 if (strEQ(d,"glob")) return KEY_glob;
4514 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4519 if (strEQ(d,"hex")) return -KEY_hex;
4522 if (strEQ(d,"INIT")) return KEY_INIT;
4527 if (strEQ(d,"if")) return KEY_if;
4530 if (strEQ(d,"int")) return -KEY_int;
4533 if (strEQ(d,"index")) return -KEY_index;
4534 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4539 if (strEQ(d,"join")) return -KEY_join;
4543 if (strEQ(d,"keys")) return KEY_keys;
4544 if (strEQ(d,"kill")) return -KEY_kill;
4549 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4550 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4556 if (strEQ(d,"lt")) return -KEY_lt;
4557 if (strEQ(d,"le")) return -KEY_le;
4558 if (strEQ(d,"lc")) return -KEY_lc;
4561 if (strEQ(d,"log")) return -KEY_log;
4564 if (strEQ(d,"last")) return KEY_last;
4565 if (strEQ(d,"link")) return -KEY_link;
4566 if (strEQ(d,"lock")) return -KEY_lock;
4569 if (strEQ(d,"local")) return KEY_local;
4570 if (strEQ(d,"lstat")) return -KEY_lstat;
4573 if (strEQ(d,"length")) return -KEY_length;
4574 if (strEQ(d,"listen")) return -KEY_listen;
4577 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4580 if (strEQ(d,"localtime")) return -KEY_localtime;
4586 case 1: return KEY_m;
4588 if (strEQ(d,"my")) return KEY_my;
4591 if (strEQ(d,"map")) return KEY_map;
4594 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4597 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4598 if (strEQ(d,"msgget")) return -KEY_msgget;
4599 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4600 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4605 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4608 if (strEQ(d,"next")) return KEY_next;
4609 if (strEQ(d,"ne")) return -KEY_ne;
4610 if (strEQ(d,"not")) return -KEY_not;
4611 if (strEQ(d,"no")) return KEY_no;
4616 if (strEQ(d,"or")) return -KEY_or;
4619 if (strEQ(d,"ord")) return -KEY_ord;
4620 if (strEQ(d,"oct")) return -KEY_oct;
4621 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4625 if (strEQ(d,"open")) return -KEY_open;
4628 if (strEQ(d,"opendir")) return -KEY_opendir;
4635 if (strEQ(d,"pop")) return KEY_pop;
4636 if (strEQ(d,"pos")) return KEY_pos;
4639 if (strEQ(d,"push")) return KEY_push;
4640 if (strEQ(d,"pack")) return -KEY_pack;
4641 if (strEQ(d,"pipe")) return -KEY_pipe;
4644 if (strEQ(d,"print")) return KEY_print;
4647 if (strEQ(d,"printf")) return KEY_printf;
4650 if (strEQ(d,"package")) return KEY_package;
4653 if (strEQ(d,"prototype")) return KEY_prototype;
4658 if (strEQ(d,"q")) return KEY_q;
4659 if (strEQ(d,"qr")) return KEY_qr;
4660 if (strEQ(d,"qq")) return KEY_qq;
4661 if (strEQ(d,"qw")) return KEY_qw;
4662 if (strEQ(d,"qx")) return KEY_qx;
4664 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4669 if (strEQ(d,"ref")) return -KEY_ref;
4672 if (strEQ(d,"read")) return -KEY_read;
4673 if (strEQ(d,"rand")) return -KEY_rand;
4674 if (strEQ(d,"recv")) return -KEY_recv;
4675 if (strEQ(d,"redo")) return KEY_redo;
4678 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4679 if (strEQ(d,"reset")) return -KEY_reset;
4682 if (strEQ(d,"return")) return KEY_return;
4683 if (strEQ(d,"rename")) return -KEY_rename;
4684 if (strEQ(d,"rindex")) return -KEY_rindex;
4687 if (strEQ(d,"require")) return -KEY_require;
4688 if (strEQ(d,"reverse")) return -KEY_reverse;
4689 if (strEQ(d,"readdir")) return -KEY_readdir;
4692 if (strEQ(d,"readlink")) return -KEY_readlink;
4693 if (strEQ(d,"readline")) return -KEY_readline;
4694 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4697 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4703 case 0: return KEY_s;
4705 if (strEQ(d,"scalar")) return KEY_scalar;
4710 if (strEQ(d,"seek")) return -KEY_seek;
4711 if (strEQ(d,"send")) return -KEY_send;
4714 if (strEQ(d,"semop")) return -KEY_semop;
4717 if (strEQ(d,"select")) return -KEY_select;
4718 if (strEQ(d,"semctl")) return -KEY_semctl;
4719 if (strEQ(d,"semget")) return -KEY_semget;
4722 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4723 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4726 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4727 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4730 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4733 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4734 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4735 if (strEQ(d,"setservent")) return -KEY_setservent;
4738 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4739 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4746 if (strEQ(d,"shift")) return KEY_shift;
4749 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4750 if (strEQ(d,"shmget")) return -KEY_shmget;
4753 if (strEQ(d,"shmread")) return -KEY_shmread;
4756 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4757 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4762 if (strEQ(d,"sin")) return -KEY_sin;
4765 if (strEQ(d,"sleep")) return -KEY_sleep;
4768 if (strEQ(d,"sort")) return KEY_sort;
4769 if (strEQ(d,"socket")) return -KEY_socket;
4770 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4773 if (strEQ(d,"split")) return KEY_split;
4774 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4775 if (strEQ(d,"splice")) return KEY_splice;
4778 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4781 if (strEQ(d,"srand")) return -KEY_srand;
4784 if (strEQ(d,"stat")) return -KEY_stat;
4785 if (strEQ(d,"study")) return KEY_study;
4788 if (strEQ(d,"substr")) return -KEY_substr;
4789 if (strEQ(d,"sub")) return KEY_sub;
4794 if (strEQ(d,"system")) return -KEY_system;
4797 if (strEQ(d,"symlink")) return -KEY_symlink;
4798 if (strEQ(d,"syscall")) return -KEY_syscall;
4799 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4800 if (strEQ(d,"sysread")) return -KEY_sysread;
4801 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4804 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4813 if (strEQ(d,"tr")) return KEY_tr;
4816 if (strEQ(d,"tie")) return KEY_tie;
4819 if (strEQ(d,"tell")) return -KEY_tell;
4820 if (strEQ(d,"tied")) return KEY_tied;
4821 if (strEQ(d,"time")) return -KEY_time;
4824 if (strEQ(d,"times")) return -KEY_times;
4827 if (strEQ(d,"telldir")) return -KEY_telldir;
4830 if (strEQ(d,"truncate")) return -KEY_truncate;
4837 if (strEQ(d,"uc")) return -KEY_uc;
4840 if (strEQ(d,"use")) return KEY_use;
4843 if (strEQ(d,"undef")) return KEY_undef;
4844 if (strEQ(d,"until")) return KEY_until;
4845 if (strEQ(d,"untie")) return KEY_untie;
4846 if (strEQ(d,"utime")) return -KEY_utime;
4847 if (strEQ(d,"umask")) return -KEY_umask;
4850 if (strEQ(d,"unless")) return KEY_unless;
4851 if (strEQ(d,"unpack")) return -KEY_unpack;
4852 if (strEQ(d,"unlink")) return -KEY_unlink;
4855 if (strEQ(d,"unshift")) return KEY_unshift;
4856 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4861 if (strEQ(d,"values")) return -KEY_values;
4862 if (strEQ(d,"vec")) return -KEY_vec;
4867 if (strEQ(d,"warn")) return -KEY_warn;
4868 if (strEQ(d,"wait")) return -KEY_wait;
4871 if (strEQ(d,"while")) return KEY_while;
4872 if (strEQ(d,"write")) return -KEY_write;
4875 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4878 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4883 if (len == 1) return -KEY_x;
4884 if (strEQ(d,"xor")) return -KEY_xor;
4887 if (len == 1) return KEY_y;
4896 S_checkcomma(pTHX_ register char *s, char *name, char *what)
4900 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4901 dTHR; /* only for ckWARN */
4902 if (ckWARN(WARN_SYNTAX)) {
4904 for (w = s+2; *w && level; w++) {
4911 for (; *w && isSPACE(*w); w++) ;
4912 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4913 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
4916 while (s < PL_bufend && isSPACE(*s))
4920 while (s < PL_bufend && isSPACE(*s))
4922 if (isIDFIRST_lazy(s)) {
4924 while (isALNUM_lazy(s))
4926 while (s < PL_bufend && isSPACE(*s))
4931 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
4935 Perl_croak(aTHX_ "No comma allowed after %s", what);
4941 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4944 HV *table = GvHV(PL_hintgv); /* ^H */
4947 bool oldcatch = CATCH_GET;
4952 yyerror("%^H is not defined");
4955 cvp = hv_fetch(table, key, strlen(key), FALSE);
4956 if (!cvp || !SvOK(*cvp)) {
4958 sprintf(buf,"$^H{%s} is not defined", key);
4962 sv_2mortal(sv); /* Parent created it permanently */
4965 pv = sv_2mortal(newSVpvn(s, len));
4967 typesv = sv_2mortal(newSVpv(type, 0));
4969 typesv = &PL_sv_undef;
4971 Zero(&myop, 1, BINOP);
4972 myop.op_last = (OP *) &myop;
4973 myop.op_next = Nullop;
4974 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4976 PUSHSTACKi(PERLSI_OVERLOAD);
4979 PL_op = (OP *) &myop;
4980 if (PERLDB_SUB && PL_curstash != PL_debstash)
4981 PL_op->op_private |= OPpENTERSUB_DB;
4983 Perl_pp_pushmark(aTHX);
4992 if (PL_op = Perl_pp_entersub(aTHX))
4999 CATCH_SET(oldcatch);
5004 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5007 return SvREFCNT_inc(res);
5011 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5013 register char *d = dest;
5014 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5017 Perl_croak(aTHX_ ident_too_long);
5018 if (isALNUM(*s)) /* UTF handled below */
5020 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5025 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5029 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5030 char *t = s + UTF8SKIP(s);
5031 while (*t & 0x80 && is_utf8_mark((U8*)t))
5033 if (d + (t - s) > e)
5034 Perl_croak(aTHX_ ident_too_long);
5035 Copy(s, d, t - s, char);
5048 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5055 if (PL_lex_brackets == 0)
5056 PL_lex_fakebrack = 0;
5060 e = d + destlen - 3; /* two-character token, ending NUL */
5062 while (isDIGIT(*s)) {
5064 Perl_croak(aTHX_ ident_too_long);
5071 Perl_croak(aTHX_ ident_too_long);
5072 if (isALNUM(*s)) /* UTF handled below */
5074 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5079 else if (*s == ':' && s[1] == ':') {
5083 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5084 char *t = s + UTF8SKIP(s);
5085 while (*t & 0x80 && is_utf8_mark((U8*)t))
5087 if (d + (t - s) > e)
5088 Perl_croak(aTHX_ ident_too_long);
5089 Copy(s, d, t - s, char);
5100 if (PL_lex_state != LEX_NORMAL)
5101 PL_lex_state = LEX_INTERPENDMAYBE;
5104 if (*s == '$' && s[1] &&
5105 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5118 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5123 if (isSPACE(s[-1])) {
5126 if (ch != ' ' && ch != '\t') {
5132 if (isIDFIRST_lazy(d)) {
5136 while (e < send && isALNUM_lazy(e) || *e == ':') {
5138 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5141 Copy(s, d, e - s, char);
5146 while ((isALNUM(*s) || *s == ':') && d < e)
5149 Perl_croak(aTHX_ ident_too_long);
5152 while (s < send && (*s == ' ' || *s == '\t')) s++;
5153 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5154 dTHR; /* only for ckWARN */
5155 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5156 char *brack = *s == '[' ? "[...]" : "{...}";
5157 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5158 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5159 funny, dest, brack, funny, dest, brack);
5161 PL_lex_fakebrack = PL_lex_brackets+1;
5163 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5167 /* Handle extended ${^Foo} variables
5168 * 1999-02-27 mjd-perl-patch@plover.com */
5169 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5173 while (isALNUM(*s) && d < e) {
5177 Perl_croak(aTHX_ ident_too_long);
5182 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5183 PL_lex_state = LEX_INTERPEND;
5186 if (PL_lex_state == LEX_NORMAL) {
5187 dTHR; /* only for ckWARN */
5188 if (ckWARN(WARN_AMBIGUOUS) &&
5189 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5191 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5192 "Ambiguous use of %c{%s} resolved to %c%s",
5193 funny, dest, funny, dest);
5198 s = bracket; /* let the parser handle it */
5202 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5203 PL_lex_state = LEX_INTERPEND;
5208 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5213 *pmfl |= PMf_GLOBAL;
5215 *pmfl |= PMf_CONTINUE;
5219 *pmfl |= PMf_MULTILINE;
5221 *pmfl |= PMf_SINGLELINE;
5223 *pmfl |= PMf_EXTENDED;
5227 S_scan_pat(pTHX_ char *start, I32 type)
5232 s = scan_str(start);
5235 SvREFCNT_dec(PL_lex_stuff);
5236 PL_lex_stuff = Nullsv;
5237 Perl_croak(aTHX_ "Search pattern not terminated");
5240 pm = (PMOP*)newPMOP(type, 0);
5241 if (PL_multi_open == '?')
5242 pm->op_pmflags |= PMf_ONCE;
5244 while (*s && strchr("iomsx", *s))
5245 pmflag(&pm->op_pmflags,*s++);
5248 while (*s && strchr("iogcmsx", *s))
5249 pmflag(&pm->op_pmflags,*s++);
5251 pm->op_pmpermflags = pm->op_pmflags;
5253 PL_lex_op = (OP*)pm;
5254 yylval.ival = OP_MATCH;
5259 S_scan_subst(pTHX_ char *start)
5266 yylval.ival = OP_NULL;
5268 s = scan_str(start);
5272 SvREFCNT_dec(PL_lex_stuff);
5273 PL_lex_stuff = Nullsv;
5274 Perl_croak(aTHX_ "Substitution pattern not terminated");
5277 if (s[-1] == PL_multi_open)
5280 first_start = PL_multi_start;
5284 SvREFCNT_dec(PL_lex_stuff);
5285 PL_lex_stuff = Nullsv;
5287 SvREFCNT_dec(PL_lex_repl);
5288 PL_lex_repl = Nullsv;
5289 Perl_croak(aTHX_ "Substitution replacement not terminated");
5291 PL_multi_start = first_start; /* so whole substitution is taken together */
5293 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5299 else if (strchr("iogcmsx", *s))
5300 pmflag(&pm->op_pmflags,*s++);
5307 PL_sublex_info.super_bufptr = s;
5308 PL_sublex_info.super_bufend = PL_bufend;
5310 pm->op_pmflags |= PMf_EVAL;
5311 repl = newSVpvn("",0);
5313 sv_catpv(repl, es ? "eval " : "do ");
5314 sv_catpvn(repl, "{ ", 2);
5315 sv_catsv(repl, PL_lex_repl);
5316 sv_catpvn(repl, " };", 2);
5318 SvREFCNT_dec(PL_lex_repl);
5322 pm->op_pmpermflags = pm->op_pmflags;
5323 PL_lex_op = (OP*)pm;
5324 yylval.ival = OP_SUBST;
5329 S_scan_trans(pTHX_ char *start)
5340 yylval.ival = OP_NULL;
5342 s = scan_str(start);
5345 SvREFCNT_dec(PL_lex_stuff);
5346 PL_lex_stuff = Nullsv;
5347 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5349 if (s[-1] == PL_multi_open)
5355 SvREFCNT_dec(PL_lex_stuff);
5356 PL_lex_stuff = Nullsv;
5358 SvREFCNT_dec(PL_lex_repl);
5359 PL_lex_repl = Nullsv;
5360 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5364 o = newSVOP(OP_TRANS, 0, 0);
5365 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5368 New(803,tbl,256,short);
5369 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5373 complement = del = squash = 0;
5374 while (strchr("cdsCU", *s)) {
5376 complement = OPpTRANS_COMPLEMENT;
5378 del = OPpTRANS_DELETE;
5380 squash = OPpTRANS_SQUASH;
5385 utf8 &= ~OPpTRANS_FROM_UTF;
5387 utf8 |= OPpTRANS_FROM_UTF;
5391 utf8 &= ~OPpTRANS_TO_UTF;
5393 utf8 |= OPpTRANS_TO_UTF;
5396 Perl_croak(aTHX_ "Too many /C and /U options");
5401 o->op_private = del|squash|complement|utf8;
5404 yylval.ival = OP_TRANS;
5409 S_scan_heredoc(pTHX_ register char *s)
5413 I32 op_type = OP_SCALAR;
5420 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5424 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5427 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5428 if (*peek && strchr("`'\"",*peek)) {
5431 s = delimcpy(d, e, s, PL_bufend, term, &len);
5441 if (!isALNUM_lazy(s))
5442 deprecate("bare << to mean <<\"\"");
5443 for (; isALNUM_lazy(s); s++) {
5448 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5449 Perl_croak(aTHX_ "Delimiter for here document is too long");
5452 len = d - PL_tokenbuf;
5453 #ifndef PERL_STRICT_CR
5454 d = strchr(s, '\r');
5458 while (s < PL_bufend) {
5464 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5473 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5478 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5479 herewas = newSVpvn(s,PL_bufend-s);
5481 s--, herewas = newSVpvn(s,d-s);
5482 s += SvCUR(herewas);
5484 tmpstr = NEWSV(87,79);
5485 sv_upgrade(tmpstr, SVt_PVIV);
5490 else if (term == '`') {
5491 op_type = OP_BACKTICK;
5492 SvIVX(tmpstr) = '\\';
5496 PL_multi_start = PL_curcop->cop_line;
5497 PL_multi_open = PL_multi_close = '<';
5498 term = *PL_tokenbuf;
5499 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5500 char *bufptr = PL_sublex_info.super_bufptr;
5501 char *bufend = PL_sublex_info.super_bufend;
5502 char *olds = s - SvCUR(herewas);
5503 s = strchr(bufptr, '\n');
5507 while (s < bufend &&
5508 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5510 PL_curcop->cop_line++;
5513 PL_curcop->cop_line = PL_multi_start;
5514 missingterm(PL_tokenbuf);
5516 sv_setpvn(herewas,bufptr,d-bufptr+1);
5517 sv_setpvn(tmpstr,d+1,s-d);
5519 sv_catpvn(herewas,s,bufend-s);
5520 (void)strcpy(bufptr,SvPVX(herewas));
5527 while (s < PL_bufend &&
5528 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5530 PL_curcop->cop_line++;
5532 if (s >= PL_bufend) {
5533 PL_curcop->cop_line = PL_multi_start;
5534 missingterm(PL_tokenbuf);
5536 sv_setpvn(tmpstr,d+1,s-d);
5538 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5540 sv_catpvn(herewas,s,PL_bufend-s);
5541 sv_setsv(PL_linestr,herewas);
5542 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5543 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5546 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5547 while (s >= PL_bufend) { /* multiple line string? */
5549 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5550 PL_curcop->cop_line = PL_multi_start;
5551 missingterm(PL_tokenbuf);
5553 PL_curcop->cop_line++;
5554 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5555 #ifndef PERL_STRICT_CR
5556 if (PL_bufend - PL_linestart >= 2) {
5557 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5558 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5560 PL_bufend[-2] = '\n';
5562 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5564 else if (PL_bufend[-1] == '\r')
5565 PL_bufend[-1] = '\n';
5567 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5568 PL_bufend[-1] = '\n';
5570 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5571 SV *sv = NEWSV(88,0);
5573 sv_upgrade(sv, SVt_PVMG);
5574 sv_setsv(sv,PL_linestr);
5575 av_store(GvAV(PL_curcop->cop_filegv),
5576 (I32)PL_curcop->cop_line,sv);
5578 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5581 sv_catsv(PL_linestr,herewas);
5582 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5586 sv_catsv(tmpstr,PL_linestr);
5591 PL_multi_end = PL_curcop->cop_line;
5592 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5593 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5594 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5596 SvREFCNT_dec(herewas);
5597 PL_lex_stuff = tmpstr;
5598 yylval.ival = op_type;
5603 takes: current position in input buffer
5604 returns: new position in input buffer
5605 side-effects: yylval and lex_op are set.
5610 <FH> read from filehandle
5611 <pkg::FH> read from package qualified filehandle
5612 <pkg'FH> read from package qualified filehandle
5613 <$fh> read from filehandle in $fh
5619 S_scan_inputsymbol(pTHX_ char *start)
5621 register char *s = start; /* current position in buffer */
5627 d = PL_tokenbuf; /* start of temp holding space */
5628 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5629 end = strchr(s, '\n');
5632 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
5634 /* die if we didn't have space for the contents of the <>,
5635 or if it didn't end, or if we see a newline
5638 if (len >= sizeof PL_tokenbuf)
5639 Perl_croak(aTHX_ "Excessively long <> operator");
5641 Perl_croak(aTHX_ "Unterminated <> operator");
5646 Remember, only scalar variables are interpreted as filehandles by
5647 this code. Anything more complex (e.g., <$fh{$num}>) will be
5648 treated as a glob() call.
5649 This code makes use of the fact that except for the $ at the front,
5650 a scalar variable and a filehandle look the same.
5652 if (*d == '$' && d[1]) d++;
5654 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5655 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5658 /* If we've tried to read what we allow filehandles to look like, and
5659 there's still text left, then it must be a glob() and not a getline.
5660 Use scan_str to pull out the stuff between the <> and treat it
5661 as nothing more than a string.
5664 if (d - PL_tokenbuf != len) {
5665 yylval.ival = OP_GLOB;
5667 s = scan_str(start);
5669 Perl_croak(aTHX_ "Glob not terminated");
5673 /* we're in a filehandle read situation */
5676 /* turn <> into <ARGV> */
5678 (void)strcpy(d,"ARGV");
5680 /* if <$fh>, create the ops to turn the variable into a
5686 /* try to find it in the pad for this block, otherwise find
5687 add symbol table ops
5689 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5690 OP *o = newOP(OP_PADSV, 0);
5692 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5695 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5696 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5697 newUNOP(OP_RV2SV, 0,
5698 newGVOP(OP_GV, 0, gv)));
5700 PL_lex_op->op_flags |= OPf_SPECIAL;
5701 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5702 yylval.ival = OP_NULL;
5705 /* If it's none of the above, it must be a literal filehandle
5706 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5708 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5709 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5710 yylval.ival = OP_NULL;
5719 takes: start position in buffer
5720 returns: position to continue reading from buffer
5721 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5722 updates the read buffer.
5724 This subroutine pulls a string out of the input. It is called for:
5725 q single quotes q(literal text)
5726 ' single quotes 'literal text'
5727 qq double quotes qq(interpolate $here please)
5728 " double quotes "interpolate $here please"
5729 qx backticks qx(/bin/ls -l)
5730 ` backticks `/bin/ls -l`
5731 qw quote words @EXPORT_OK = qw( func() $spam )
5732 m// regexp match m/this/
5733 s/// regexp substitute s/this/that/
5734 tr/// string transliterate tr/this/that/
5735 y/// string transliterate y/this/that/
5736 ($*@) sub prototypes sub foo ($)
5737 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5739 In most of these cases (all but <>, patterns and transliterate)
5740 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5741 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5742 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5745 It skips whitespace before the string starts, and treats the first
5746 character as the delimiter. If the delimiter is one of ([{< then
5747 the corresponding "close" character )]}> is used as the closing
5748 delimiter. It allows quoting of delimiters, and if the string has
5749 balanced delimiters ([{<>}]) it allows nesting.
5751 The lexer always reads these strings into lex_stuff, except in the
5752 case of the operators which take *two* arguments (s/// and tr///)
5753 when it checks to see if lex_stuff is full (presumably with the 1st
5754 arg to s or tr) and if so puts the string into lex_repl.
5759 S_scan_str(pTHX_ char *start)
5762 SV *sv; /* scalar value: string */
5763 char *tmps; /* temp string, used for delimiter matching */
5764 register char *s = start; /* current position in the buffer */
5765 register char term; /* terminating character */
5766 register char *to; /* current position in the sv's data */
5767 I32 brackets = 1; /* bracket nesting level */
5769 /* skip space before the delimiter */
5773 /* mark where we are, in case we need to report errors */
5776 /* after skipping whitespace, the next character is the terminator */
5778 /* mark where we are */
5779 PL_multi_start = PL_curcop->cop_line;
5780 PL_multi_open = term;
5782 /* find corresponding closing delimiter */
5783 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5785 PL_multi_close = term;
5787 /* create a new SV to hold the contents. 87 is leak category, I'm
5788 assuming. 79 is the SV's initial length. What a random number. */
5790 sv_upgrade(sv, SVt_PVIV);
5792 (void)SvPOK_only(sv); /* validate pointer */
5794 /* move past delimiter and try to read a complete string */
5797 /* extend sv if need be */
5798 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5799 /* set 'to' to the next character in the sv's string */
5800 to = SvPVX(sv)+SvCUR(sv);
5802 /* if open delimiter is the close delimiter read unbridle */
5803 if (PL_multi_open == PL_multi_close) {
5804 for (; s < PL_bufend; s++,to++) {
5805 /* embedded newlines increment the current line number */
5806 if (*s == '\n' && !PL_rsfp)
5807 PL_curcop->cop_line++;
5808 /* handle quoted delimiters */
5809 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5812 /* any other quotes are simply copied straight through */
5816 /* terminate when run out of buffer (the for() condition), or
5817 have found the terminator */
5818 else if (*s == term)
5824 /* if the terminator isn't the same as the start character (e.g.,
5825 matched brackets), we have to allow more in the quoting, and
5826 be prepared for nested brackets.
5829 /* read until we run out of string, or we find the terminator */
5830 for (; s < PL_bufend; s++,to++) {
5831 /* embedded newlines increment the line count */
5832 if (*s == '\n' && !PL_rsfp)
5833 PL_curcop->cop_line++;
5834 /* backslashes can escape the open or closing characters */
5835 if (*s == '\\' && s+1 < PL_bufend) {
5836 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5841 /* allow nested opens and closes */
5842 else if (*s == PL_multi_close && --brackets <= 0)
5844 else if (*s == PL_multi_open)
5849 /* terminate the copied string and update the sv's end-of-string */
5851 SvCUR_set(sv, to - SvPVX(sv));
5854 * this next chunk reads more into the buffer if we're not done yet
5857 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5859 #ifndef PERL_STRICT_CR
5860 if (to - SvPVX(sv) >= 2) {
5861 if ((to[-2] == '\r' && to[-1] == '\n') ||
5862 (to[-2] == '\n' && to[-1] == '\r'))
5866 SvCUR_set(sv, to - SvPVX(sv));
5868 else if (to[-1] == '\r')
5871 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5875 /* if we're out of file, or a read fails, bail and reset the current
5876 line marker so we can report where the unterminated string began
5879 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5881 PL_curcop->cop_line = PL_multi_start;
5884 /* we read a line, so increment our line counter */
5885 PL_curcop->cop_line++;
5887 /* update debugger info */
5888 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5889 SV *sv = NEWSV(88,0);
5891 sv_upgrade(sv, SVt_PVMG);
5892 sv_setsv(sv,PL_linestr);
5893 av_store(GvAV(PL_curcop->cop_filegv),
5894 (I32)PL_curcop->cop_line, sv);
5897 /* having changed the buffer, we must update PL_bufend */
5898 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5901 /* at this point, we have successfully read the delimited string */
5903 PL_multi_end = PL_curcop->cop_line;
5906 /* if we allocated too much space, give some back */
5907 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5908 SvLEN_set(sv, SvCUR(sv) + 1);
5909 Renew(SvPVX(sv), SvLEN(sv), char);
5912 /* decide whether this is the first or second quoted string we've read
5925 takes: pointer to position in buffer
5926 returns: pointer to new position in buffer
5927 side-effects: builds ops for the constant in yylval.op
5929 Read a number in any of the formats that Perl accepts:
5931 0(x[0-7A-F]+)|([0-7]+)|(b[01])
5932 [\d_]+(\.[\d_]*)?[Ee](\d+)
5934 Underbars (_) are allowed in decimal numbers. If -w is on,
5935 underbars before a decimal point must be at three digit intervals.
5937 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5940 If it reads a number without a decimal point or an exponent, it will
5941 try converting the number to an integer and see if it can do so
5942 without loss of precision.
5946 Perl_scan_num(pTHX_ char *start)
5948 register char *s = start; /* current position in buffer */
5949 register char *d; /* destination in temp buffer */
5950 register char *e; /* end of temp buffer */
5951 I32 tryiv; /* used to see if it can be an int */
5952 NV value; /* number read, as a double */
5953 SV *sv; /* place to put the converted number */
5954 I32 floatit; /* boolean: int or float? */
5955 char *lastub = 0; /* position of last underbar */
5956 static char number_too_long[] = "Number too long";
5958 /* We use the first character to decide what type of number this is */
5962 Perl_croak(aTHX_ "panic: scan_num");
5964 /* if it starts with a 0, it could be an octal number, a decimal in
5965 0.13 disguise, or a hexadecimal number, or a binary number.
5970 u holds the "number so far"
5971 shift the power of 2 of the base
5972 (hex == 4, octal == 3, binary == 1)
5973 overflowed was the number more than we can hold?
5975 Shift is used when we add a digit. It also serves as an "are
5976 we in octal/hex/binary?" indicator to disallow hex characters
5982 bool overflowed = FALSE;
5988 } else if (s[1] == 'b') {
5992 /* check for a decimal in disguise */
5993 else if (s[1] == '.')
5995 /* so it must be octal */
6000 /* read the rest of the number */
6002 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
6006 /* if we don't mention it, we're done */
6015 /* 8 and 9 are not octal */
6018 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6021 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6025 case '2': case '3': case '4':
6026 case '5': case '6': case '7':
6028 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6032 b = *s++ & 15; /* ASCII digit -> value of digit */
6036 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6037 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6038 /* make sure they said 0x */
6043 /* Prepare to put the digit we have onto the end
6044 of the number so far. We check for overflows.
6048 n = u << shift; /* make room for the digit */
6049 if (!overflowed && (n >> shift) != u
6050 && !(PL_hints & HINT_NEW_BINARY))
6052 if (ckWARN_d(WARN_UNSAFE))
6053 Perl_warner(aTHX_ WARN_UNSAFE,
6054 "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 && (NV)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;
6419 restore_rsfp(pTHXo_ void *f)
6421 PerlIO *fp = (PerlIO*)f;
6423 if (PL_rsfp == PerlIO_stdin())
6424 PerlIO_clearerr(PL_rsfp);
6425 else if (PL_rsfp && (PL_rsfp != fp))
6426 PerlIO_close(PL_rsfp);
6431 restore_expect(pTHXo_ void *e)
6433 /* a safe way to store a small integer in a pointer */
6434 PL_expect = (expectation)((char *)e - PL_tokenbuf);
6438 restore_lex_expect(pTHXo_ void *e)
6440 /* a safe way to store a small integer in a pointer */
6441 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);