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);
160 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
162 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
163 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
165 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
166 if (t < PL_bufptr && isSPACE(*t))
167 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
168 t - PL_oldoldbufptr, PL_oldoldbufptr);
171 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
176 S_missingterm(pTHX_ char *s)
181 char *nl = strrchr(s,'\n');
187 iscntrl(PL_multi_close)
189 PL_multi_close < 32 || PL_multi_close == 127
193 tmpbuf[1] = toCTRL(PL_multi_close);
199 *tmpbuf = PL_multi_close;
203 q = strchr(s,'"') ? '\'' : '"';
204 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
208 Perl_deprecate(pTHX_ char *s)
211 if (ckWARN(WARN_DEPRECATED))
212 Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
218 deprecate("comma-less variable list");
224 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
226 I32 count = FILTER_READ(idx+1, sv, maxlen);
227 if (count > 0 && !maxlen)
228 win32_strip_return(sv);
234 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
236 I32 count = FILTER_READ(idx+1, sv, maxlen);
240 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
241 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
242 sv_usepvn(sv, (char*)tmps, tend - tmps);
249 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
251 I32 count = FILTER_READ(idx+1, sv, maxlen);
255 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
256 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
257 sv_usepvn(sv, (char*)tmps, tend - tmps);
264 Perl_lex_start(pTHX_ SV *line)
270 SAVEI32(PL_lex_dojoin);
271 SAVEI32(PL_lex_brackets);
272 SAVEI32(PL_lex_fakebrack);
273 SAVEI32(PL_lex_casemods);
274 SAVEI32(PL_lex_starts);
275 SAVEI32(PL_lex_state);
276 SAVESPTR(PL_lex_inpat);
277 SAVEI32(PL_lex_inwhat);
278 SAVEI16(PL_curcop->cop_line);
281 SAVEPPTR(PL_oldbufptr);
282 SAVEPPTR(PL_oldoldbufptr);
283 SAVEPPTR(PL_linestart);
284 SAVESPTR(PL_linestr);
285 SAVEPPTR(PL_lex_brackstack);
286 SAVEPPTR(PL_lex_casestack);
287 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
288 SAVESPTR(PL_lex_stuff);
289 SAVEI32(PL_lex_defer);
290 SAVESPTR(PL_lex_repl);
291 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
292 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
294 PL_lex_state = LEX_NORMAL;
298 PL_lex_fakebrack = 0;
299 New(899, PL_lex_brackstack, 120, char);
300 New(899, PL_lex_casestack, 12, char);
301 SAVEFREEPV(PL_lex_brackstack);
302 SAVEFREEPV(PL_lex_casestack);
304 *PL_lex_casestack = '\0';
307 PL_lex_stuff = Nullsv;
308 PL_lex_repl = Nullsv;
312 if (SvREADONLY(PL_linestr))
313 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
314 s = SvPV(PL_linestr, len);
315 if (len && s[len-1] != ';') {
316 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
317 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
318 sv_catpvn(PL_linestr, "\n;", 2);
320 SvTEMP_off(PL_linestr);
321 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
322 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
324 PL_rs = newSVpvn("\n", 1);
331 PL_doextract = FALSE;
335 S_incline(pTHX_ char *s)
343 PL_curcop->cop_line++;
346 while (*s == ' ' || *s == '\t') s++;
347 if (strnEQ(s, "line ", 5)) {
356 while (*s == ' ' || *s == '\t')
358 if (*s == '"' && (t = strchr(s+1, '"')))
362 return; /* false alarm */
363 for (t = s; !isSPACE(*t); t++) ;
368 PL_curcop->cop_filegv = gv_fetchfile(s);
370 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
372 PL_curcop->cop_line = atoi(n)-1;
376 S_skipspace(pTHX_ register char *s)
379 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
380 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
386 while (s < PL_bufend && isSPACE(*s)) {
387 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
390 if (s < PL_bufend && *s == '#') {
391 while (s < PL_bufend && *s != '\n')
395 if (PL_in_eval && !PL_rsfp) {
401 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
403 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
404 if (PL_minus_n || PL_minus_p) {
405 sv_setpv(PL_linestr,PL_minus_p ?
406 ";}continue{print or die qq(-p destination: $!\\n)" :
408 sv_catpv(PL_linestr,";}");
409 PL_minus_n = PL_minus_p = 0;
412 sv_setpv(PL_linestr,";");
413 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
414 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
415 if (PL_preprocess && !PL_in_eval)
416 (void)PerlProc_pclose(PL_rsfp);
417 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
418 PerlIO_clearerr(PL_rsfp);
420 (void)PerlIO_close(PL_rsfp);
424 PL_linestart = PL_bufptr = s + prevlen;
425 PL_bufend = s + SvCUR(PL_linestr);
428 if (PERLDB_LINE && PL_curstash != PL_debstash) {
429 SV *sv = NEWSV(85,0);
431 sv_upgrade(sv, SVt_PVMG);
432 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
433 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
445 if (PL_oldoldbufptr != PL_last_uni)
447 while (isSPACE(*PL_last_uni))
449 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
450 if ((t = strchr(s, '(')) && t < PL_bufptr)
452 if (ckWARN_d(WARN_AMBIGUOUS)){
455 Perl_warner(aTHX_ WARN_AMBIGUOUS,
456 "Warning: Use of \"%s\" without parens is ambiguous",
465 #define UNI(f) return uni(f,s)
468 S_uni(pTHX_ I32 f, char *s)
473 PL_last_uni = PL_oldbufptr;
484 #endif /* CRIPPLED_CC */
486 #define LOP(f,x) return lop(f,x,s)
489 S_lop(pTHX_ I32 f, expectation x, char *s)
496 PL_last_lop = PL_oldbufptr;
510 S_force_next(pTHX_ I32 type)
512 PL_nexttype[PL_nexttoke] = type;
514 if (PL_lex_state != LEX_KNOWNEXT) {
515 PL_lex_defer = PL_lex_state;
516 PL_lex_expect = PL_expect;
517 PL_lex_state = LEX_KNOWNEXT;
522 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
527 start = skipspace(start);
529 if (isIDFIRST_lazy(s) ||
530 (allow_pack && *s == ':') ||
531 (allow_initial_tick && *s == '\'') )
533 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
534 if (check_keyword && keyword(PL_tokenbuf, len))
536 if (token == METHOD) {
541 PL_expect = XOPERATOR;
544 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
545 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
552 S_force_ident(pTHX_ register char *s, int kind)
555 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
556 PL_nextval[PL_nexttoke].opval = o;
559 dTHR; /* just for in_eval */
560 o->op_private = OPpCONST_ENTERED;
561 /* XXX see note in pp_entereval() for why we forgo typo
562 warnings if the symbol must be introduced in an eval.
564 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
565 kind == '$' ? SVt_PV :
566 kind == '@' ? SVt_PVAV :
567 kind == '%' ? SVt_PVHV :
575 S_force_version(pTHX_ char *s)
577 OP *version = Nullop;
581 /* default VERSION number -- GBARR */
586 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
587 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
589 /* real VERSION number -- GBARR */
590 version = yylval.opval;
594 /* NOTE: The parser sees the package name and the VERSION swapped */
595 PL_nextval[PL_nexttoke].opval = version;
602 S_tokeq(pTHX_ SV *sv)
613 s = SvPV_force(sv, len);
617 while (s < send && *s != '\\')
622 if ( PL_hints & HINT_NEW_STRING )
623 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
626 if (s + 1 < send && (s[1] == '\\'))
627 s++; /* all that, just for this */
632 SvCUR_set(sv, d - SvPVX(sv));
634 if ( PL_hints & HINT_NEW_STRING )
635 return new_constant(NULL, 0, "q", sv, pv, "q");
642 register I32 op_type = yylval.ival;
644 if (op_type == OP_NULL) {
645 yylval.opval = PL_lex_op;
649 if (op_type == OP_CONST || op_type == OP_READLINE) {
650 SV *sv = tokeq(PL_lex_stuff);
652 if (SvTYPE(sv) == SVt_PVIV) {
653 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
659 nsv = newSVpvn(p, len);
663 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
664 PL_lex_stuff = Nullsv;
668 PL_sublex_info.super_state = PL_lex_state;
669 PL_sublex_info.sub_inwhat = op_type;
670 PL_sublex_info.sub_op = PL_lex_op;
671 PL_lex_state = LEX_INTERPPUSH;
675 yylval.opval = PL_lex_op;
689 PL_lex_state = PL_sublex_info.super_state;
690 SAVEI32(PL_lex_dojoin);
691 SAVEI32(PL_lex_brackets);
692 SAVEI32(PL_lex_fakebrack);
693 SAVEI32(PL_lex_casemods);
694 SAVEI32(PL_lex_starts);
695 SAVEI32(PL_lex_state);
696 SAVESPTR(PL_lex_inpat);
697 SAVEI32(PL_lex_inwhat);
698 SAVEI16(PL_curcop->cop_line);
700 SAVEPPTR(PL_oldbufptr);
701 SAVEPPTR(PL_oldoldbufptr);
702 SAVEPPTR(PL_linestart);
703 SAVESPTR(PL_linestr);
704 SAVEPPTR(PL_lex_brackstack);
705 SAVEPPTR(PL_lex_casestack);
707 PL_linestr = PL_lex_stuff;
708 PL_lex_stuff = Nullsv;
710 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
711 PL_bufend += SvCUR(PL_linestr);
712 SAVEFREESV(PL_linestr);
714 PL_lex_dojoin = FALSE;
716 PL_lex_fakebrack = 0;
717 New(899, PL_lex_brackstack, 120, char);
718 New(899, PL_lex_casestack, 12, char);
719 SAVEFREEPV(PL_lex_brackstack);
720 SAVEFREEPV(PL_lex_casestack);
722 *PL_lex_casestack = '\0';
724 PL_lex_state = LEX_INTERPCONCAT;
725 PL_curcop->cop_line = PL_multi_start;
727 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
728 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
729 PL_lex_inpat = PL_sublex_info.sub_op;
731 PL_lex_inpat = Nullop;
739 if (!PL_lex_starts++) {
740 PL_expect = XOPERATOR;
741 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
745 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
746 PL_lex_state = LEX_INTERPCASEMOD;
750 /* Is there a right-hand side to take care of? */
751 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
752 PL_linestr = PL_lex_repl;
754 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
755 PL_bufend += SvCUR(PL_linestr);
756 SAVEFREESV(PL_linestr);
757 PL_lex_dojoin = FALSE;
759 PL_lex_fakebrack = 0;
761 *PL_lex_casestack = '\0';
763 if (SvEVALED(PL_lex_repl)) {
764 PL_lex_state = LEX_INTERPNORMAL;
766 /* we don't clear PL_lex_repl here, so that we can check later
767 whether this is an evalled subst; that means we rely on the
768 logic to ensure sublex_done() is called again only via the
769 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
772 PL_lex_state = LEX_INTERPCONCAT;
773 PL_lex_repl = Nullsv;
779 PL_bufend = SvPVX(PL_linestr);
780 PL_bufend += SvCUR(PL_linestr);
781 PL_expect = XOPERATOR;
789 Extracts a pattern, double-quoted string, or transliteration. This
792 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
793 processing a pattern (PL_lex_inpat is true), a transliteration
794 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
796 Returns a pointer to the character scanned up to. Iff this is
797 advanced from the start pointer supplied (ie if anything was
798 successfully parsed), will leave an OP for the substring scanned
799 in yylval. Caller must intuit reason for not parsing further
800 by looking at the next characters herself.
804 double-quoted style: \r and \n
805 regexp special ones: \D \s
807 backrefs: \1 (deprecated in substitution replacements)
808 case and quoting: \U \Q \E
809 stops on @ and $, but not for $ as tail anchor
812 characters are VERY literal, except for - not at the start or end
813 of the string, which indicates a range. scan_const expands the
814 range to the full set of intermediate characters.
816 In double-quoted strings:
818 double-quoted style: \r and \n
820 backrefs: \1 (deprecated)
821 case and quoting: \U \Q \E
824 scan_const does *not* construct ops to handle interpolated strings.
825 It stops processing as soon as it finds an embedded $ or @ variable
826 and leaves it to the caller to work out what's going on.
828 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
830 $ in pattern could be $foo or could be tail anchor. Assumption:
831 it's a tail anchor if $ is the last thing in the string, or if it's
832 followed by one of ")| \n\t"
834 \1 (backreferences) are turned into $1
836 The structure of the code is
837 while (there's a character to process) {
838 handle transliteration ranges
840 skip # initiated comments in //x patterns
841 check for embedded @foo
842 check for embedded scalars
844 leave intact backslashes from leave (below)
845 deprecate \1 in strings and sub replacements
846 handle string-changing backslashes \l \U \Q \E, etc.
847 switch (what was escaped) {
848 handle - in a transliteration (becomes a literal -)
849 handle \132 octal characters
850 handle 0x15 hex characters
851 handle \cV (control V)
852 handle printf backslashes (\f, \r, \n, etc)
855 } (end while character to read)
860 S_scan_const(pTHX_ char *start)
862 register char *send = PL_bufend; /* end of the constant */
863 SV *sv = NEWSV(93, send - start); /* sv for the constant */
864 register char *s = start; /* start of the constant */
865 register char *d = SvPVX(sv); /* destination for copies */
866 bool dorange = FALSE; /* are we in a translit range? */
868 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
869 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
871 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
872 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
875 /* leaveit is the set of acceptably-backslashed characters */
878 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
881 while (s < send || dorange) {
882 /* get transliterations out of the way (they're most literal) */
883 if (PL_lex_inwhat == OP_TRANS) {
884 /* expand a range A-Z to the full set of characters. AIE! */
886 I32 i; /* current expanded character */
887 I32 min; /* first character in range */
888 I32 max; /* last character in range */
890 i = d - SvPVX(sv); /* remember current offset */
891 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
892 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
893 d -= 2; /* eat the first char and the - */
895 min = (U8)*d; /* first char in range */
896 max = (U8)d[1]; /* last char in range */
899 if ((isLOWER(min) && isLOWER(max)) ||
900 (isUPPER(min) && isUPPER(max))) {
902 for (i = min; i <= max; i++)
906 for (i = min; i <= max; i++)
913 for (i = min; i <= max; i++)
916 /* mark the range as done, and continue */
921 /* range begins (ignore - as first or last char) */
922 else if (*s == '-' && s+1 < send && s != start) {
924 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
933 /* if we get here, we're not doing a transliteration */
935 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
936 except for the last char, which will be done separately. */
937 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
939 while (s < send && *s != ')')
941 } else if (s[2] == '{'
942 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
944 char *regparse = s + (s[2] == '{' ? 3 : 4);
947 while (count && (c = *regparse)) {
948 if (c == '\\' && regparse[1])
956 if (*regparse != ')') {
957 regparse--; /* Leave one char for continuation. */
958 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
965 /* likewise skip #-initiated comments in //x patterns */
966 else if (*s == '#' && PL_lex_inpat &&
967 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
968 while (s+1 < send && *s != '\n')
972 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
973 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
976 /* check for embedded scalars. only stop if we're sure it's a
979 else if (*s == '$') {
980 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
982 if (s + 1 < send && !strchr("()| \n\t", s[1]))
983 break; /* in regexp, $ might be tail anchor */
986 /* (now in tr/// code again) */
988 if (*s & 0x80 && thisutf) {
989 dTHR; /* only for ckWARN */
990 if (ckWARN(WARN_UTF8)) {
991 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1001 if (*s == '\\' && s+1 < send) {
1004 /* some backslashes we leave behind */
1005 if (*leaveit && *s && strchr(leaveit, *s)) {
1011 /* deprecate \1 in strings and substitution replacements */
1012 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1013 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1015 dTHR; /* only for ckWARN */
1016 if (ckWARN(WARN_SYNTAX))
1017 Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1022 /* string-change backslash escapes */
1023 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1028 /* if we get here, it's either a quoted -, or a digit */
1031 /* quoted - in transliterations */
1033 if (PL_lex_inwhat == OP_TRANS) {
1041 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1042 Perl_warner(aTHX_ WARN_UNSAFE,
1043 "Unrecognized escape \\%c passed through",
1045 /* default action is to copy the quoted character */
1050 /* \132 indicates an octal constant */
1051 case '0': case '1': case '2': case '3':
1052 case '4': case '5': case '6': case '7':
1053 *d++ = scan_oct(s, 3, &len);
1057 /* \x24 indicates a hex constant */
1061 char* e = strchr(s, '}');
1064 yyerror("Missing right brace on \\x{}");
1069 if (ckWARN(WARN_UTF8))
1070 Perl_warner(aTHX_ WARN_UTF8,
1071 "Use of \\x{} without utf8 declaration");
1073 /* note: utf always shorter than hex */
1074 d = (char*)uv_to_utf8((U8*)d,
1075 scan_hex(s + 1, e - s - 1, &len));
1080 UV uv = (UV)scan_hex(s, 2, &len);
1081 if (utf && PL_lex_inwhat == OP_TRANS &&
1082 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1084 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1087 if (uv >= 127 && UTF) {
1089 if (ckWARN(WARN_UTF8))
1090 Perl_warner(aTHX_ WARN_UTF8,
1091 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1100 /* \c is a control character */
1114 /* printf-style backslashes, formfeeds, newlines, etc */
1132 *d++ = '\047'; /* CP 1047 */
1135 *d++ = '\057'; /* CP 1047 */
1149 } /* end if (backslash) */
1152 } /* while loop to process each character */
1154 /* terminate the string and set up the sv */
1156 SvCUR_set(sv, d - SvPVX(sv));
1159 /* shrink the sv if we allocated more than we used */
1160 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1161 SvLEN_set(sv, SvCUR(sv) + 1);
1162 Renew(SvPVX(sv), SvLEN(sv), char);
1165 /* return the substring (via yylval) only if we parsed anything */
1166 if (s > PL_bufptr) {
1167 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1168 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1170 ( PL_lex_inwhat == OP_TRANS
1172 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1175 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1181 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1183 S_intuit_more(pTHX_ register char *s)
1185 if (PL_lex_brackets)
1187 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1189 if (*s != '{' && *s != '[')
1194 /* In a pattern, so maybe we have {n,m}. */
1211 /* On the other hand, maybe we have a character class */
1214 if (*s == ']' || *s == '^')
1217 int weight = 2; /* let's weigh the evidence */
1219 unsigned char un_char = 255, last_un_char;
1220 char *send = strchr(s,']');
1221 char tmpbuf[sizeof PL_tokenbuf * 4];
1223 if (!send) /* has to be an expression */
1226 Zero(seen,256,char);
1229 else if (isDIGIT(*s)) {
1231 if (isDIGIT(s[1]) && s[2] == ']')
1237 for (; s < send; s++) {
1238 last_un_char = un_char;
1239 un_char = (unsigned char)*s;
1244 weight -= seen[un_char] * 10;
1245 if (isALNUM_lazy(s+1)) {
1246 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1247 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1252 else if (*s == '$' && s[1] &&
1253 strchr("[#!%*<>()-=",s[1])) {
1254 if (/*{*/ strchr("])} =",s[2]))
1263 if (strchr("wds]",s[1]))
1265 else if (seen['\''] || seen['"'])
1267 else if (strchr("rnftbxcav",s[1]))
1269 else if (isDIGIT(s[1])) {
1271 while (s[1] && isDIGIT(s[1]))
1281 if (strchr("aA01! ",last_un_char))
1283 if (strchr("zZ79~",s[1]))
1285 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1286 weight -= 5; /* cope with negative subscript */
1289 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1290 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1295 if (keyword(tmpbuf, d - tmpbuf))
1298 if (un_char == last_un_char + 1)
1300 weight -= seen[un_char];
1305 if (weight >= 0) /* probably a character class */
1313 S_intuit_method(pTHX_ char *start, GV *gv)
1315 char *s = start + (*start == '$');
1316 char tmpbuf[sizeof PL_tokenbuf];
1324 if ((cv = GvCVu(gv))) {
1325 char *proto = SvPVX(cv);
1335 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1336 if (*start == '$') {
1337 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1342 return *s == '(' ? FUNCMETH : METHOD;
1344 if (!keyword(tmpbuf, len)) {
1345 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1350 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1351 if (indirgv && GvCVu(indirgv))
1353 /* filehandle or package name makes it a method */
1354 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1356 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1357 return 0; /* no assumptions -- "=>" quotes bearword */
1359 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1360 newSVpvn(tmpbuf,len));
1361 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1365 return *s == '(' ? FUNCMETH : METHOD;
1375 char *pdb = PerlEnv_getenv("PERL5DB");
1379 SETERRNO(0,SS$_NORMAL);
1380 return "BEGIN { require 'perl5db.pl' }";
1386 /* Encoded script support. filter_add() effectively inserts a
1387 * 'pre-processing' function into the current source input stream.
1388 * Note that the filter function only applies to the current source file
1389 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1391 * The datasv parameter (which may be NULL) can be used to pass
1392 * private data to this instance of the filter. The filter function
1393 * can recover the SV using the FILTER_DATA macro and use it to
1394 * store private buffers and state information.
1396 * The supplied datasv parameter is upgraded to a PVIO type
1397 * and the IoDIRP field is used to store the function pointer.
1398 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1399 * private use must be set using malloc'd pointers.
1403 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1405 if (!funcp){ /* temporary handy debugging hack to be deleted */
1406 PL_filter_debug = atoi((char*)datasv);
1409 if (!PL_rsfp_filters)
1410 PL_rsfp_filters = newAV();
1412 datasv = NEWSV(255,0);
1413 if (!SvUPGRADE(datasv, SVt_PVIO))
1414 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1415 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1417 if (PL_filter_debug) {
1419 Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1421 #endif /* DEBUGGING */
1422 av_unshift(PL_rsfp_filters, 1);
1423 av_store(PL_rsfp_filters, 0, datasv) ;
1428 /* Delete most recently added instance of this filter function. */
1430 Perl_filter_del(pTHX_ filter_t funcp)
1433 if (PL_filter_debug)
1434 Perl_warn(aTHX_ "filter_del func %p", funcp);
1435 #endif /* DEBUGGING */
1436 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1438 /* if filter is on top of stack (usual case) just pop it off */
1439 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1440 IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1441 sv_free(av_pop(PL_rsfp_filters));
1445 /* we need to search for the correct entry and clear it */
1446 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1450 /* Invoke the n'th filter function for the current rsfp. */
1452 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1455 /* 0 = read one text line */
1460 if (!PL_rsfp_filters)
1462 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1463 /* Provide a default input filter to make life easy. */
1464 /* Note that we append to the line. This is handy. */
1466 if (PL_filter_debug)
1467 Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
1468 #endif /* DEBUGGING */
1472 int old_len = SvCUR(buf_sv) ;
1474 /* ensure buf_sv is large enough */
1475 SvGROW(buf_sv, old_len + maxlen) ;
1476 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1477 if (PerlIO_error(PL_rsfp))
1478 return -1; /* error */
1480 return 0 ; /* end of file */
1482 SvCUR_set(buf_sv, old_len + len) ;
1485 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1486 if (PerlIO_error(PL_rsfp))
1487 return -1; /* error */
1489 return 0 ; /* end of file */
1492 return SvCUR(buf_sv);
1494 /* Skip this filter slot if filter has been deleted */
1495 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1497 if (PL_filter_debug)
1498 Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
1499 #endif /* DEBUGGING */
1500 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1502 /* Get function pointer hidden within datasv */
1503 funcp = (filter_t)IoDIRP(datasv);
1505 if (PL_filter_debug) {
1507 Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
1508 idx, funcp, SvPV(datasv,n_a));
1510 #endif /* DEBUGGING */
1511 /* Call function. The function is expected to */
1512 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1513 /* Return: <0:error, =0:eof, >0:not eof */
1514 return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1518 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1521 if (!PL_rsfp_filters) {
1522 filter_add(win32_textfilter,NULL);
1525 if (PL_rsfp_filters) {
1528 SvCUR_set(sv, 0); /* start with empty line */
1529 if (FILTER_READ(0, sv, 0) > 0)
1530 return ( SvPVX(sv) ) ;
1535 return (sv_gets(sv, fp, append));
1540 static char* exp_name[] =
1541 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1547 Works out what to call the token just pulled out of the input
1548 stream. The yacc parser takes care of taking the ops we return and
1549 stitching them into a tree.
1555 if read an identifier
1556 if we're in a my declaration
1557 croak if they tried to say my($foo::bar)
1558 build the ops for a my() declaration
1559 if it's an access to a my() variable
1560 are we in a sort block?
1561 croak if my($a); $a <=> $b
1562 build ops for access to a my() variable
1563 if in a dq string, and they've said @foo and we can't find @foo
1565 build ops for a bareword
1566 if we already built the token before, use it.
1570 #ifdef USE_PURE_BISON
1571 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1584 #ifdef USE_PURE_BISON
1585 yylval_pointer = lvalp;
1586 yychar_pointer = lcharp;
1589 /* check if there's an identifier for us to look at */
1590 if (PL_pending_ident) {
1591 /* pit holds the identifier we read and pending_ident is reset */
1592 char pit = PL_pending_ident;
1593 PL_pending_ident = 0;
1595 /* if we're in a my(), we can't allow dynamics here.
1596 $foo'bar has already been turned into $foo::bar, so
1597 just check for colons.
1599 if it's a legal name, the OP is a PADANY.
1602 if (strchr(PL_tokenbuf,':'))
1603 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1605 yylval.opval = newOP(OP_PADANY, 0);
1606 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1611 build the ops for accesses to a my() variable.
1613 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1614 then used in a comparison. This catches most, but not
1615 all cases. For instance, it catches
1616 sort { my($a); $a <=> $b }
1618 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1619 (although why you'd do that is anyone's guess).
1622 if (!strchr(PL_tokenbuf,':')) {
1624 /* Check for single character per-thread SVs */
1625 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1626 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1627 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1629 yylval.opval = newOP(OP_THREADSV, 0);
1630 yylval.opval->op_targ = tmp;
1633 #endif /* USE_THREADS */
1634 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1635 /* if it's a sort block and they're naming $a or $b */
1636 if (PL_last_lop_op == OP_SORT &&
1637 PL_tokenbuf[0] == '$' &&
1638 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1641 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1642 d < PL_bufend && *d != '\n';
1645 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1646 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
1652 yylval.opval = newOP(OP_PADANY, 0);
1653 yylval.opval->op_targ = tmp;
1659 Whine if they've said @foo in a doublequoted string,
1660 and @foo isn't a variable we can find in the symbol
1663 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1664 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1665 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1666 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
1667 PL_tokenbuf, PL_tokenbuf));
1670 /* build ops for a bareword */
1671 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1672 yylval.opval->op_private = OPpCONST_ENTERED;
1673 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1674 ((PL_tokenbuf[0] == '$') ? SVt_PV
1675 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1680 /* no identifier pending identification */
1682 switch (PL_lex_state) {
1684 case LEX_NORMAL: /* Some compilers will produce faster */
1685 case LEX_INTERPNORMAL: /* code if we comment these out. */
1689 /* when we're already built the next token, just pull it out the queue */
1692 yylval = PL_nextval[PL_nexttoke];
1694 PL_lex_state = PL_lex_defer;
1695 PL_expect = PL_lex_expect;
1696 PL_lex_defer = LEX_NORMAL;
1698 return(PL_nexttype[PL_nexttoke]);
1700 /* interpolated case modifiers like \L \U, including \Q and \E.
1701 when we get here, PL_bufptr is at the \
1703 case LEX_INTERPCASEMOD:
1705 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1706 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
1708 /* handle \E or end of string */
1709 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1713 if (PL_lex_casemods) {
1714 oldmod = PL_lex_casestack[--PL_lex_casemods];
1715 PL_lex_casestack[PL_lex_casemods] = '\0';
1717 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1719 PL_lex_state = LEX_INTERPCONCAT;
1723 if (PL_bufptr != PL_bufend)
1725 PL_lex_state = LEX_INTERPCONCAT;
1730 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1731 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1732 if (strchr("LU", *s) &&
1733 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1735 PL_lex_casestack[--PL_lex_casemods] = '\0';
1738 if (PL_lex_casemods > 10) {
1739 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1740 if (newlb != PL_lex_casestack) {
1742 PL_lex_casestack = newlb;
1745 PL_lex_casestack[PL_lex_casemods++] = *s;
1746 PL_lex_casestack[PL_lex_casemods] = '\0';
1747 PL_lex_state = LEX_INTERPCONCAT;
1748 PL_nextval[PL_nexttoke].ival = 0;
1751 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1753 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1755 PL_nextval[PL_nexttoke].ival = OP_LC;
1757 PL_nextval[PL_nexttoke].ival = OP_UC;
1759 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1761 Perl_croak(aTHX_ "panic: yylex");
1764 if (PL_lex_starts) {
1773 case LEX_INTERPPUSH:
1774 return sublex_push();
1776 case LEX_INTERPSTART:
1777 if (PL_bufptr == PL_bufend)
1778 return sublex_done();
1780 PL_lex_dojoin = (*PL_bufptr == '@');
1781 PL_lex_state = LEX_INTERPNORMAL;
1782 if (PL_lex_dojoin) {
1783 PL_nextval[PL_nexttoke].ival = 0;
1786 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1787 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1788 force_next(PRIVATEREF);
1790 force_ident("\"", '$');
1791 #endif /* USE_THREADS */
1792 PL_nextval[PL_nexttoke].ival = 0;
1794 PL_nextval[PL_nexttoke].ival = 0;
1796 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1799 if (PL_lex_starts++) {
1805 case LEX_INTERPENDMAYBE:
1806 if (intuit_more(PL_bufptr)) {
1807 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1813 if (PL_lex_dojoin) {
1814 PL_lex_dojoin = FALSE;
1815 PL_lex_state = LEX_INTERPCONCAT;
1818 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
1819 && SvEVALED(PL_lex_repl))
1821 if (PL_bufptr != PL_bufend)
1822 Perl_croak(aTHX_ "Bad evalled substitution pattern");
1823 PL_lex_repl = Nullsv;
1826 case LEX_INTERPCONCAT:
1828 if (PL_lex_brackets)
1829 Perl_croak(aTHX_ "panic: INTERPCONCAT");
1831 if (PL_bufptr == PL_bufend)
1832 return sublex_done();
1834 if (SvIVX(PL_linestr) == '\'') {
1835 SV *sv = newSVsv(PL_linestr);
1838 else if ( PL_hints & HINT_NEW_RE )
1839 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1840 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1844 s = scan_const(PL_bufptr);
1846 PL_lex_state = LEX_INTERPCASEMOD;
1848 PL_lex_state = LEX_INTERPSTART;
1851 if (s != PL_bufptr) {
1852 PL_nextval[PL_nexttoke] = yylval;
1855 if (PL_lex_starts++)
1865 PL_lex_state = LEX_NORMAL;
1866 s = scan_formline(PL_bufptr);
1867 if (!PL_lex_formbrack)
1873 PL_oldoldbufptr = PL_oldbufptr;
1876 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1882 if (isIDFIRST_lazy(s))
1884 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
1887 goto fake_eof; /* emulate EOF on ^D or ^Z */
1892 if (PL_lex_brackets)
1893 yyerror("Missing right curly or square bracket");
1896 if (s++ < PL_bufend)
1897 goto retry; /* ignore stray nulls */
1900 if (!PL_in_eval && !PL_preambled) {
1901 PL_preambled = TRUE;
1902 sv_setpv(PL_linestr,incl_perldb());
1903 if (SvCUR(PL_linestr))
1904 sv_catpv(PL_linestr,";");
1906 while(AvFILLp(PL_preambleav) >= 0) {
1907 SV *tmpsv = av_shift(PL_preambleav);
1908 sv_catsv(PL_linestr, tmpsv);
1909 sv_catpv(PL_linestr, ";");
1912 sv_free((SV*)PL_preambleav);
1913 PL_preambleav = NULL;
1915 if (PL_minus_n || PL_minus_p) {
1916 sv_catpv(PL_linestr, "LINE: while (<>) {");
1918 sv_catpv(PL_linestr,"chomp;");
1920 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1922 GvIMPORTED_AV_on(gv);
1924 if (strchr("/'\"", *PL_splitstr)
1925 && strchr(PL_splitstr + 1, *PL_splitstr))
1926 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
1929 s = "'~#\200\1'"; /* surely one char is unused...*/
1930 while (s[1] && strchr(PL_splitstr, *s)) s++;
1932 Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
1933 "q" + (delim == '\''), delim);
1934 for (s = PL_splitstr; *s; s++) {
1936 sv_catpvn(PL_linestr, "\\", 1);
1937 sv_catpvn(PL_linestr, s, 1);
1939 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
1943 sv_catpv(PL_linestr,"@F=split(' ');");
1946 sv_catpv(PL_linestr, "\n");
1947 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1948 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1949 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1950 SV *sv = NEWSV(85,0);
1952 sv_upgrade(sv, SVt_PVMG);
1953 sv_setsv(sv,PL_linestr);
1954 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1959 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1962 if (PL_preprocess && !PL_in_eval)
1963 (void)PerlProc_pclose(PL_rsfp);
1964 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1965 PerlIO_clearerr(PL_rsfp);
1967 (void)PerlIO_close(PL_rsfp);
1969 PL_doextract = FALSE;
1971 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1972 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1973 sv_catpv(PL_linestr,";}");
1974 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1975 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1976 PL_minus_n = PL_minus_p = 0;
1979 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1980 sv_setpv(PL_linestr,"");
1981 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1984 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1985 PL_doextract = FALSE;
1987 /* Incest with pod. */
1988 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1989 sv_setpv(PL_linestr, "");
1990 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1991 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1992 PL_doextract = FALSE;
1996 } while (PL_doextract);
1997 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1998 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1999 SV *sv = NEWSV(85,0);
2001 sv_upgrade(sv, SVt_PVMG);
2002 sv_setsv(sv,PL_linestr);
2003 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2005 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2006 if (PL_curcop->cop_line == 1) {
2007 while (s < PL_bufend && isSPACE(*s))
2009 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2013 if (*s == '#' && *(s+1) == '!')
2015 #ifdef ALTERNATE_SHEBANG
2017 static char as[] = ALTERNATE_SHEBANG;
2018 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2019 d = s + (sizeof(as) - 1);
2021 #endif /* ALTERNATE_SHEBANG */
2030 while (*d && !isSPACE(*d))
2034 #ifdef ARG_ZERO_IS_SCRIPT
2035 if (ipathend > ipath) {
2037 * HP-UX (at least) sets argv[0] to the script name,
2038 * which makes $^X incorrect. And Digital UNIX and Linux,
2039 * at least, set argv[0] to the basename of the Perl
2040 * interpreter. So, having found "#!", we'll set it right.
2042 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2043 assert(SvPOK(x) || SvGMAGICAL(x));
2044 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2045 sv_setpvn(x, ipath, ipathend - ipath);
2048 TAINT_NOT; /* $^X is always tainted, but that's OK */
2050 #endif /* ARG_ZERO_IS_SCRIPT */
2055 d = instr(s,"perl -");
2057 d = instr(s,"perl");
2058 #ifdef ALTERNATE_SHEBANG
2060 * If the ALTERNATE_SHEBANG on this system starts with a
2061 * character that can be part of a Perl expression, then if
2062 * we see it but not "perl", we're probably looking at the
2063 * start of Perl code, not a request to hand off to some
2064 * other interpreter. Similarly, if "perl" is there, but
2065 * not in the first 'word' of the line, we assume the line
2066 * contains the start of the Perl program.
2068 if (d && *s != '#') {
2070 while (*c && !strchr("; \t\r\n\f\v#", *c))
2073 d = Nullch; /* "perl" not in first word; ignore */
2075 *s = '#'; /* Don't try to parse shebang line */
2077 #endif /* ALTERNATE_SHEBANG */
2082 !instr(s,"indir") &&
2083 instr(PL_origargv[0],"perl"))
2089 while (s < PL_bufend && isSPACE(*s))
2091 if (s < PL_bufend) {
2092 Newz(899,newargv,PL_origargc+3,char*);
2094 while (s < PL_bufend && !isSPACE(*s))
2097 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2100 newargv = PL_origargv;
2102 PerlProc_execv(ipath, newargv);
2103 Perl_croak(aTHX_ "Can't exec %s", ipath);
2106 U32 oldpdb = PL_perldb;
2107 bool oldn = PL_minus_n;
2108 bool oldp = PL_minus_p;
2110 while (*d && !isSPACE(*d)) d++;
2111 while (*d == ' ' || *d == '\t') d++;
2115 if (*d == 'M' || *d == 'm') {
2117 while (*d && !isSPACE(*d)) d++;
2118 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2121 d = moreswitches(d);
2123 if (PERLDB_LINE && !oldpdb ||
2124 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2125 /* if we have already added "LINE: while (<>) {",
2126 we must not do it again */
2128 sv_setpv(PL_linestr, "");
2129 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2130 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2131 PL_preambled = FALSE;
2133 (void)gv_fetchfile(PL_origfilename);
2140 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2142 PL_lex_state = LEX_FORMLINE;
2147 #ifdef PERL_STRICT_CR
2148 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2150 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2152 case ' ': case '\t': case '\f': case 013:
2157 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2159 while (s < d && *s != '\n')
2164 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2166 PL_lex_state = LEX_FORMLINE;
2176 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2181 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2184 if (strnEQ(s,"=>",2)) {
2185 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2186 OPERATOR('-'); /* unary minus */
2188 PL_last_uni = PL_oldbufptr;
2189 PL_last_lop_op = OP_FTEREAD; /* good enough */
2191 case 'r': FTST(OP_FTEREAD);
2192 case 'w': FTST(OP_FTEWRITE);
2193 case 'x': FTST(OP_FTEEXEC);
2194 case 'o': FTST(OP_FTEOWNED);
2195 case 'R': FTST(OP_FTRREAD);
2196 case 'W': FTST(OP_FTRWRITE);
2197 case 'X': FTST(OP_FTREXEC);
2198 case 'O': FTST(OP_FTROWNED);
2199 case 'e': FTST(OP_FTIS);
2200 case 'z': FTST(OP_FTZERO);
2201 case 's': FTST(OP_FTSIZE);
2202 case 'f': FTST(OP_FTFILE);
2203 case 'd': FTST(OP_FTDIR);
2204 case 'l': FTST(OP_FTLINK);
2205 case 'p': FTST(OP_FTPIPE);
2206 case 'S': FTST(OP_FTSOCK);
2207 case 'u': FTST(OP_FTSUID);
2208 case 'g': FTST(OP_FTSGID);
2209 case 'k': FTST(OP_FTSVTX);
2210 case 'b': FTST(OP_FTBLK);
2211 case 'c': FTST(OP_FTCHR);
2212 case 't': FTST(OP_FTTTY);
2213 case 'T': FTST(OP_FTTEXT);
2214 case 'B': FTST(OP_FTBINARY);
2215 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2216 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2217 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2219 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2226 if (PL_expect == XOPERATOR)
2231 else if (*s == '>') {
2234 if (isIDFIRST_lazy(s)) {
2235 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2243 if (PL_expect == XOPERATOR)
2246 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2248 OPERATOR('-'); /* unary minus */
2255 if (PL_expect == XOPERATOR)
2260 if (PL_expect == XOPERATOR)
2263 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2269 if (PL_expect != XOPERATOR) {
2270 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2271 PL_expect = XOPERATOR;
2272 force_ident(PL_tokenbuf, '*');
2285 if (PL_expect == XOPERATOR) {
2289 PL_tokenbuf[0] = '%';
2290 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2291 if (!PL_tokenbuf[1]) {
2293 yyerror("Final % should be \\% or %name");
2296 PL_pending_ident = '%';
2318 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2319 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2324 if (PL_curcop->cop_line < PL_copline)
2325 PL_copline = PL_curcop->cop_line;
2336 if (PL_lex_brackets <= 0)
2337 yyerror("Unmatched right square bracket");
2340 if (PL_lex_state == LEX_INTERPNORMAL) {
2341 if (PL_lex_brackets == 0) {
2342 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2343 PL_lex_state = LEX_INTERPEND;
2350 if (PL_lex_brackets > 100) {
2351 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2352 if (newlb != PL_lex_brackstack) {
2354 PL_lex_brackstack = newlb;
2357 switch (PL_expect) {
2359 if (PL_lex_formbrack) {
2363 if (PL_oldoldbufptr == PL_last_lop)
2364 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2366 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2367 OPERATOR(HASHBRACK);
2369 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2372 PL_tokenbuf[0] = '\0';
2373 if (d < PL_bufend && *d == '-') {
2374 PL_tokenbuf[0] = '-';
2376 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2379 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2380 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2382 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2385 char minus = (PL_tokenbuf[0] == '-');
2386 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2393 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2397 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2402 if (PL_oldoldbufptr == PL_last_lop)
2403 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2405 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2408 OPERATOR(HASHBRACK);
2409 /* This hack serves to disambiguate a pair of curlies
2410 * as being a block or an anon hash. Normally, expectation
2411 * determines that, but in cases where we're not in a
2412 * position to expect anything in particular (like inside
2413 * eval"") we have to resolve the ambiguity. This code
2414 * covers the case where the first term in the curlies is a
2415 * quoted string. Most other cases need to be explicitly
2416 * disambiguated by prepending a `+' before the opening
2417 * curly in order to force resolution as an anon hash.
2419 * XXX should probably propagate the outer expectation
2420 * into eval"" to rely less on this hack, but that could
2421 * potentially break current behavior of eval"".
2425 if (*s == '\'' || *s == '"' || *s == '`') {
2426 /* common case: get past first string, handling escapes */
2427 for (t++; t < PL_bufend && *t != *s;)
2428 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2432 else if (*s == 'q') {
2435 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2436 && !isALNUM(*t)))) {
2438 char open, close, term;
2441 while (t < PL_bufend && isSPACE(*t))
2445 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2449 for (t++; t < PL_bufend; t++) {
2450 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2452 else if (*t == open)
2456 for (t++; t < PL_bufend; t++) {
2457 if (*t == '\\' && t+1 < PL_bufend)
2459 else if (*t == close && --brackets <= 0)
2461 else if (*t == open)
2467 else if (isIDFIRST_lazy(s)) {
2468 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2470 while (t < PL_bufend && isSPACE(*t))
2472 /* if comma follows first term, call it an anon hash */
2473 /* XXX it could be a comma expression with loop modifiers */
2474 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2475 || (*t == '=' && t[1] == '>')))
2476 OPERATOR(HASHBRACK);
2477 if (PL_expect == XREF)
2480 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2486 yylval.ival = PL_curcop->cop_line;
2487 if (isSPACE(*s) || *s == '#')
2488 PL_copline = NOLINE; /* invalidate current command line number */
2493 if (PL_lex_brackets <= 0)
2494 yyerror("Unmatched right curly bracket");
2496 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2497 if (PL_lex_brackets < PL_lex_formbrack)
2498 PL_lex_formbrack = 0;
2499 if (PL_lex_state == LEX_INTERPNORMAL) {
2500 if (PL_lex_brackets == 0) {
2501 if (PL_lex_fakebrack) {
2502 PL_lex_state = LEX_INTERPEND;
2504 return yylex(); /* ignore fake brackets */
2506 if (*s == '-' && s[1] == '>')
2507 PL_lex_state = LEX_INTERPENDMAYBE;
2508 else if (*s != '[' && *s != '{')
2509 PL_lex_state = LEX_INTERPEND;
2512 if (PL_lex_brackets < PL_lex_fakebrack) {
2514 PL_lex_fakebrack = 0;
2515 return yylex(); /* ignore fake brackets */
2525 if (PL_expect == XOPERATOR) {
2526 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2527 PL_curcop->cop_line--;
2528 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
2529 PL_curcop->cop_line++;
2534 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2536 PL_expect = XOPERATOR;
2537 force_ident(PL_tokenbuf, '&');
2541 yylval.ival = (OPpENTERSUB_AMPER<<8);
2560 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2561 Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2563 if (PL_expect == XSTATE && isALPHA(tmp) &&
2564 (s == PL_linestart+1 || s[-2] == '\n') )
2566 if (PL_in_eval && !PL_rsfp) {
2571 if (strnEQ(s,"=cut",4)) {
2585 PL_doextract = TRUE;
2588 if (PL_lex_brackets < PL_lex_formbrack) {
2590 #ifdef PERL_STRICT_CR
2591 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2593 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2595 if (*t == '\n' || *t == '#') {
2613 if (PL_expect != XOPERATOR) {
2614 if (s[1] != '<' && !strchr(s,'>'))
2617 s = scan_heredoc(s);
2619 s = scan_inputsymbol(s);
2620 TERM(sublex_start());
2625 SHop(OP_LEFT_SHIFT);
2639 SHop(OP_RIGHT_SHIFT);
2648 if (PL_expect == XOPERATOR) {
2649 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2652 return ','; /* grandfather non-comma-format format */
2656 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2657 PL_tokenbuf[0] = '@';
2658 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
2659 sizeof PL_tokenbuf - 1, FALSE);
2660 if (PL_expect == XOPERATOR)
2661 no_op("Array length", s);
2662 if (!PL_tokenbuf[1])
2664 PL_expect = XOPERATOR;
2665 PL_pending_ident = '#';
2669 PL_tokenbuf[0] = '$';
2670 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
2671 sizeof PL_tokenbuf - 1, FALSE);
2672 if (PL_expect == XOPERATOR)
2674 if (!PL_tokenbuf[1]) {
2676 yyerror("Final $ should be \\$ or $name");
2680 /* This kludge not intended to be bulletproof. */
2681 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2682 yylval.opval = newSVOP(OP_CONST, 0,
2683 newSViv((IV)PL_compiling.cop_arybase));
2684 yylval.opval->op_private = OPpCONST_ARYBASE;
2690 if (PL_lex_state == LEX_NORMAL)
2693 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2696 PL_tokenbuf[0] = '@';
2697 if (ckWARN(WARN_SYNTAX)) {
2699 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2702 PL_bufptr = skipspace(PL_bufptr);
2703 while (t < PL_bufend && *t != ']')
2705 Perl_warner(aTHX_ WARN_SYNTAX,
2706 "Multidimensional syntax %.*s not supported",
2707 (t - PL_bufptr) + 1, PL_bufptr);
2711 else if (*s == '{') {
2712 PL_tokenbuf[0] = '%';
2713 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2714 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2716 char tmpbuf[sizeof PL_tokenbuf];
2718 for (t++; isSPACE(*t); t++) ;
2719 if (isIDFIRST_lazy(t)) {
2720 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2721 for (; isSPACE(*t); t++) ;
2722 if (*t == ';' && get_cv(tmpbuf, FALSE))
2723 Perl_warner(aTHX_ WARN_SYNTAX,
2724 "You need to quote \"%s\"", tmpbuf);
2730 PL_expect = XOPERATOR;
2731 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
2732 bool islop = (PL_last_lop == PL_oldoldbufptr);
2733 if (!islop || PL_last_lop_op == OP_GREPSTART)
2734 PL_expect = XOPERATOR;
2735 else if (strchr("$@\"'`q", *s))
2736 PL_expect = XTERM; /* e.g. print $fh "foo" */
2737 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2738 PL_expect = XTERM; /* e.g. print $fh &sub */
2739 else if (isIDFIRST_lazy(s)) {
2740 char tmpbuf[sizeof PL_tokenbuf];
2741 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2742 if (tmp = keyword(tmpbuf, len)) {
2743 /* binary operators exclude handle interpretations */
2755 PL_expect = XTERM; /* e.g. print $fh length() */
2760 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2761 if (gv && GvCVu(gv))
2762 PL_expect = XTERM; /* e.g. print $fh subr() */
2765 else if (isDIGIT(*s))
2766 PL_expect = XTERM; /* e.g. print $fh 3 */
2767 else if (*s == '.' && isDIGIT(s[1]))
2768 PL_expect = XTERM; /* e.g. print $fh .3 */
2769 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2770 PL_expect = XTERM; /* e.g. print $fh -1 */
2771 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2772 PL_expect = XTERM; /* print $fh <<"EOF" */
2774 PL_pending_ident = '$';
2778 if (PL_expect == XOPERATOR)
2780 PL_tokenbuf[0] = '@';
2781 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2782 if (!PL_tokenbuf[1]) {
2784 yyerror("Final @ should be \\@ or @name");
2787 if (PL_lex_state == LEX_NORMAL)
2789 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2791 PL_tokenbuf[0] = '%';
2793 /* Warn about @ where they meant $. */
2794 if (ckWARN(WARN_SYNTAX)) {
2795 if (*s == '[' || *s == '{') {
2797 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2799 if (*t == '}' || *t == ']') {
2801 PL_bufptr = skipspace(PL_bufptr);
2802 Perl_warner(aTHX_ WARN_SYNTAX,
2803 "Scalar value %.*s better written as $%.*s",
2804 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2809 PL_pending_ident = '@';
2812 case '/': /* may either be division or pattern */
2813 case '?': /* may either be conditional or pattern */
2814 if (PL_expect != XOPERATOR) {
2815 /* Disable warning on "study /blah/" */
2816 if (PL_oldoldbufptr == PL_last_uni
2817 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2818 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2820 s = scan_pat(s,OP_MATCH);
2821 TERM(sublex_start());
2829 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2830 #ifdef PERL_STRICT_CR
2833 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2835 && (s == PL_linestart || s[-1] == '\n') )
2837 PL_lex_formbrack = 0;
2841 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2847 yylval.ival = OPf_SPECIAL;
2853 if (PL_expect != XOPERATOR)
2858 case '0': case '1': case '2': case '3': case '4':
2859 case '5': case '6': case '7': case '8': case '9':
2861 if (PL_expect == XOPERATOR)
2867 if (PL_expect == XOPERATOR) {
2868 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2871 return ','; /* grandfather non-comma-format format */
2877 missingterm((char*)0);
2878 yylval.ival = OP_CONST;
2879 TERM(sublex_start());
2883 if (PL_expect == XOPERATOR) {
2884 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2887 return ','; /* grandfather non-comma-format format */
2893 missingterm((char*)0);
2894 yylval.ival = OP_CONST;
2895 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2896 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2897 yylval.ival = OP_STRINGIFY;
2901 TERM(sublex_start());
2905 if (PL_expect == XOPERATOR)
2906 no_op("Backticks",s);
2908 missingterm((char*)0);
2909 yylval.ival = OP_BACKTICK;
2911 TERM(sublex_start());
2915 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2916 Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2918 if (PL_expect == XOPERATOR)
2919 no_op("Backslash",s);
2923 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2963 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2965 /* Some keywords can be followed by any delimiter, including ':' */
2966 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2967 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2968 (PL_tokenbuf[0] == 'q' &&
2969 strchr("qwxr", PL_tokenbuf[1]))));
2971 /* x::* is just a word, unless x is "CORE" */
2972 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2976 while (d < PL_bufend && isSPACE(*d))
2977 d++; /* no comments skipped here, or s### is misparsed */
2979 /* Is this a label? */
2980 if (!tmp && PL_expect == XSTATE
2981 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2983 yylval.pval = savepv(PL_tokenbuf);
2988 /* Check for keywords */
2989 tmp = keyword(PL_tokenbuf, len);
2991 /* Is this a word before a => operator? */
2992 if (strnEQ(d,"=>",2)) {
2994 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2995 yylval.opval->op_private = OPpCONST_BARE;
2999 if (tmp < 0) { /* second-class keyword? */
3000 GV *ogv = Nullgv; /* override (winner) */
3001 GV *hgv = Nullgv; /* hidden (loser) */
3002 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3004 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3007 if (GvIMPORTED_CV(gv))
3009 else if (! CvMETHOD(cv))
3013 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3014 (gv = *gvp) != (GV*)&PL_sv_undef &&
3015 GvCVu(gv) && GvIMPORTED_CV(gv))
3021 tmp = 0; /* overridden by import or by GLOBAL */
3024 && -tmp==KEY_lock /* XXX generalizable kludge */
3025 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3027 tmp = 0; /* any sub overrides "weak" keyword */
3029 else { /* no override */
3033 if (ckWARN(WARN_AMBIGUOUS) && hgv
3034 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3035 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3036 "Ambiguous call resolved as CORE::%s(), %s",
3037 GvENAME(hgv), "qualify as such or use &");
3044 default: /* not a keyword */
3047 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3049 /* Get the rest if it looks like a package qualifier */
3051 if (*s == '\'' || *s == ':' && s[1] == ':') {
3053 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3056 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3057 *s == '\'' ? "'" : "::");
3061 if (PL_expect == XOPERATOR) {
3062 if (PL_bufptr == PL_linestart) {
3063 PL_curcop->cop_line--;
3064 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3065 PL_curcop->cop_line++;
3068 no_op("Bareword",s);
3071 /* Look for a subroutine with this name in current package,
3072 unless name is "Foo::", in which case Foo is a bearword
3073 (and a package name). */
3076 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3078 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3079 Perl_warner(aTHX_ WARN_UNSAFE,
3080 "Bareword \"%s\" refers to nonexistent package",
3083 PL_tokenbuf[len] = '\0';
3090 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3093 /* if we saw a global override before, get the right name */
3096 sv = newSVpvn("CORE::GLOBAL::",14);
3097 sv_catpv(sv,PL_tokenbuf);
3100 sv = newSVpv(PL_tokenbuf,0);
3102 /* Presume this is going to be a bareword of some sort. */
3105 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3106 yylval.opval->op_private = OPpCONST_BARE;
3108 /* And if "Foo::", then that's what it certainly is. */
3113 /* See if it's the indirect object for a list operator. */
3115 if (PL_oldoldbufptr &&
3116 PL_oldoldbufptr < PL_bufptr &&
3117 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3118 /* NO SKIPSPACE BEFORE HERE! */
3119 (PL_expect == XREF ||
3120 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3122 bool immediate_paren = *s == '(';
3124 /* (Now we can afford to cross potential line boundary.) */
3127 /* Two barewords in a row may indicate method call. */
3129 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3132 /* If not a declared subroutine, it's an indirect object. */
3133 /* (But it's an indir obj regardless for sort.) */
3135 if ((PL_last_lop_op == OP_SORT ||
3136 (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3137 (PL_last_lop_op != OP_MAPSTART &&
3138 PL_last_lop_op != OP_GREPSTART))
3140 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3145 /* If followed by a paren, it's certainly a subroutine. */
3147 PL_expect = XOPERATOR;
3151 if (gv && GvCVu(gv)) {
3152 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3153 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3158 PL_nextval[PL_nexttoke].opval = yylval.opval;
3159 PL_expect = XOPERATOR;
3165 /* If followed by var or block, call it a method (unless sub) */
3167 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3168 PL_last_lop = PL_oldbufptr;
3169 PL_last_lop_op = OP_METHOD;
3173 /* If followed by a bareword, see if it looks like indir obj. */
3175 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3178 /* Not a method, so call it a subroutine (if defined) */
3180 if (gv && GvCVu(gv)) {
3182 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3183 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3184 "Ambiguous use of -%s resolved as -&%s()",
3185 PL_tokenbuf, PL_tokenbuf);
3186 /* Check for a constant sub */
3188 if ((sv = cv_const_sv(cv))) {
3190 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3191 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3192 yylval.opval->op_private = 0;
3196 /* Resolve to GV now. */
3197 op_free(yylval.opval);
3198 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3199 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3200 PL_last_lop = PL_oldbufptr;
3201 PL_last_lop_op = OP_ENTERSUB;
3202 /* Is there a prototype? */
3205 char *proto = SvPV((SV*)cv, len);
3208 if (strEQ(proto, "$"))
3210 if (*proto == '&' && *s == '{') {
3211 sv_setpv(PL_subname,"__ANON__");
3215 PL_nextval[PL_nexttoke].opval = yylval.opval;
3221 /* Call it a bare word */
3223 if (PL_hints & HINT_STRICT_SUBS)
3224 yylval.opval->op_private |= OPpCONST_STRICT;
3227 if (ckWARN(WARN_RESERVED)) {
3228 if (lastchar != '-') {
3229 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3231 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3238 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3239 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3240 "Operator or semicolon missing before %c%s",
3241 lastchar, PL_tokenbuf);
3242 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3243 "Ambiguous use of %c resolved as operator %c",
3244 lastchar, lastchar);
3250 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3251 newSVsv(GvSV(PL_curcop->cop_filegv)));
3255 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3256 Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3259 case KEY___PACKAGE__:
3260 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3262 ? newSVsv(PL_curstname)
3271 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3272 char *pname = "main";
3273 if (PL_tokenbuf[2] == 'D')
3274 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3275 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3278 GvIOp(gv) = newIO();
3279 IoIFP(GvIOp(gv)) = PL_rsfp;
3280 #if defined(HAS_FCNTL) && defined(F_SETFD)
3282 int fd = PerlIO_fileno(PL_rsfp);
3283 fcntl(fd,F_SETFD,fd >= 3);
3286 /* Mark this internal pseudo-handle as clean */
3287 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3289 IoTYPE(GvIOp(gv)) = '|';
3290 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3291 IoTYPE(GvIOp(gv)) = '-';
3293 IoTYPE(GvIOp(gv)) = '<';
3304 if (PL_expect == XSTATE) {
3311 if (*s == ':' && s[1] == ':') {
3314 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3315 tmp = keyword(PL_tokenbuf, len);
3329 LOP(OP_ACCEPT,XTERM);
3335 LOP(OP_ATAN2,XTERM);
3344 LOP(OP_BLESS,XTERM);
3353 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3370 if (!PL_cryptseen++)
3373 LOP(OP_CRYPT,XTERM);
3376 if (ckWARN(WARN_OCTAL)) {
3377 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3378 if (*d != '0' && isDIGIT(*d))
3379 yywarn("chmod: mode argument is missing initial 0");
3381 LOP(OP_CHMOD,XTERM);
3384 LOP(OP_CHOWN,XTERM);
3387 LOP(OP_CONNECT,XTERM);
3403 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3407 PL_hints |= HINT_BLOCK_SCOPE;
3417 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3418 LOP(OP_DBMOPEN,XTERM);
3424 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3431 yylval.ival = PL_curcop->cop_line;
3445 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3446 UNIBRACK(OP_ENTEREVAL);
3461 case KEY_endhostent:
3467 case KEY_endservent:
3470 case KEY_endprotoent:
3481 yylval.ival = PL_curcop->cop_line;
3483 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3485 if ((PL_bufend - p) >= 3 &&
3486 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3489 if (isIDFIRST_lazy(p))
3490 Perl_croak(aTHX_ "Missing $ on loop variable");
3495 LOP(OP_FORMLINE,XTERM);
3501 LOP(OP_FCNTL,XTERM);
3507 LOP(OP_FLOCK,XTERM);
3516 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3519 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3534 case KEY_getpriority:
3535 LOP(OP_GETPRIORITY,XTERM);
3537 case KEY_getprotobyname:
3540 case KEY_getprotobynumber:
3541 LOP(OP_GPBYNUMBER,XTERM);
3543 case KEY_getprotoent:
3555 case KEY_getpeername:
3556 UNI(OP_GETPEERNAME);
3558 case KEY_gethostbyname:
3561 case KEY_gethostbyaddr:
3562 LOP(OP_GHBYADDR,XTERM);
3564 case KEY_gethostent:
3567 case KEY_getnetbyname:
3570 case KEY_getnetbyaddr:
3571 LOP(OP_GNBYADDR,XTERM);
3576 case KEY_getservbyname:
3577 LOP(OP_GSBYNAME,XTERM);
3579 case KEY_getservbyport:
3580 LOP(OP_GSBYPORT,XTERM);
3582 case KEY_getservent:
3585 case KEY_getsockname:
3586 UNI(OP_GETSOCKNAME);
3588 case KEY_getsockopt:
3589 LOP(OP_GSOCKOPT,XTERM);
3611 yylval.ival = PL_curcop->cop_line;
3615 LOP(OP_INDEX,XTERM);
3621 LOP(OP_IOCTL,XTERM);
3633 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3664 LOP(OP_LISTEN,XTERM);
3673 s = scan_pat(s,OP_MATCH);
3674 TERM(sublex_start());
3677 LOP(OP_MAPSTART, *s == '(' ? XTERM : XREF);
3680 LOP(OP_MKDIR,XTERM);
3683 LOP(OP_MSGCTL,XTERM);
3686 LOP(OP_MSGGET,XTERM);
3689 LOP(OP_MSGRCV,XTERM);
3692 LOP(OP_MSGSND,XTERM);
3697 if (isIDFIRST_lazy(s)) {
3698 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3699 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3700 if (!PL_in_my_stash) {
3703 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3710 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3717 if (PL_expect != XSTATE)
3718 yyerror("\"no\" not allowed in expression");
3719 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3720 s = force_version(s);
3729 if (isIDFIRST_lazy(s)) {
3731 for (d = s; isALNUM_lazy(d); d++) ;
3733 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
3734 Perl_warner(aTHX_ WARN_AMBIGUOUS,
3735 "Precedence problem: open %.*s should be open(%.*s)",
3741 yylval.ival = OP_OR;
3751 LOP(OP_OPEN_DIR,XTERM);
3754 checkcomma(s,PL_tokenbuf,"filehandle");
3758 checkcomma(s,PL_tokenbuf,"filehandle");
3777 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3781 LOP(OP_PIPE_OP,XTERM);
3786 missingterm((char*)0);
3787 yylval.ival = OP_CONST;
3788 TERM(sublex_start());
3796 missingterm((char*)0);
3798 if (SvCUR(PL_lex_stuff)) {
3801 d = SvPV_force(PL_lex_stuff, len);
3803 for (; isSPACE(*d) && len; --len, ++d) ;
3806 if (!warned && ckWARN(WARN_SYNTAX)) {
3807 for (; !isSPACE(*d) && len; --len, ++d) {
3809 Perl_warner(aTHX_ WARN_SYNTAX,
3810 "Possible attempt to separate words with commas");
3813 else if (*d == '#') {
3814 Perl_warner(aTHX_ WARN_SYNTAX,
3815 "Possible attempt to put comments in qw() list");
3821 for (; !isSPACE(*d) && len; --len, ++d) ;
3823 words = append_elem(OP_LIST, words,
3824 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
3828 PL_nextval[PL_nexttoke].opval = words;
3833 SvREFCNT_dec(PL_lex_stuff);
3834 PL_lex_stuff = Nullsv;
3841 missingterm((char*)0);
3842 yylval.ival = OP_STRINGIFY;
3843 if (SvIVX(PL_lex_stuff) == '\'')
3844 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3845 TERM(sublex_start());
3848 s = scan_pat(s,OP_QR);
3849 TERM(sublex_start());
3854 missingterm((char*)0);
3855 yylval.ival = OP_BACKTICK;
3857 TERM(sublex_start());
3863 *PL_tokenbuf = '\0';
3864 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3865 if (isIDFIRST_lazy(PL_tokenbuf))
3866 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3868 yyerror("<> should be quotes");
3875 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3879 LOP(OP_RENAME,XTERM);
3888 LOP(OP_RINDEX,XTERM);
3911 LOP(OP_REVERSE,XTERM);
3922 TERM(sublex_start());
3924 TOKEN(1); /* force error */
3933 LOP(OP_SELECT,XTERM);
3939 LOP(OP_SEMCTL,XTERM);
3942 LOP(OP_SEMGET,XTERM);
3945 LOP(OP_SEMOP,XTERM);
3951 LOP(OP_SETPGRP,XTERM);
3953 case KEY_setpriority:
3954 LOP(OP_SETPRIORITY,XTERM);
3956 case KEY_sethostent:
3962 case KEY_setservent:
3965 case KEY_setprotoent:
3975 LOP(OP_SEEKDIR,XTERM);
3977 case KEY_setsockopt:
3978 LOP(OP_SSOCKOPT,XTERM);
3984 LOP(OP_SHMCTL,XTERM);
3987 LOP(OP_SHMGET,XTERM);
3990 LOP(OP_SHMREAD,XTERM);
3993 LOP(OP_SHMWRITE,XTERM);
3996 LOP(OP_SHUTDOWN,XTERM);
4005 LOP(OP_SOCKET,XTERM);
4007 case KEY_socketpair:
4008 LOP(OP_SOCKPAIR,XTERM);
4011 checkcomma(s,PL_tokenbuf,"subroutine name");
4013 if (*s == ';' || *s == ')') /* probably a close */
4014 Perl_croak(aTHX_ "sort is now a reserved word");
4016 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4020 LOP(OP_SPLIT,XTERM);
4023 LOP(OP_SPRINTF,XTERM);
4026 LOP(OP_SPLICE,XTERM);
4042 LOP(OP_SUBSTR,XTERM);
4049 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4050 char tmpbuf[sizeof PL_tokenbuf];
4052 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4053 if (strchr(tmpbuf, ':'))
4054 sv_setpv(PL_subname, tmpbuf);
4056 sv_setsv(PL_subname,PL_curstname);
4057 sv_catpvn(PL_subname,"::",2);
4058 sv_catpvn(PL_subname,tmpbuf,len);
4060 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4064 PL_expect = XTERMBLOCK;
4065 sv_setpv(PL_subname,"?");
4068 if (tmp == KEY_format) {
4071 PL_lex_formbrack = PL_lex_brackets + 1;
4075 /* Look for a prototype */
4082 SvREFCNT_dec(PL_lex_stuff);
4083 PL_lex_stuff = Nullsv;
4084 Perl_croak(aTHX_ "Prototype not terminated");
4087 d = SvPVX(PL_lex_stuff);
4089 for (p = d; *p; ++p) {
4094 SvCUR(PL_lex_stuff) = tmp;
4097 PL_nextval[1] = PL_nextval[0];
4098 PL_nexttype[1] = PL_nexttype[0];
4099 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4100 PL_nexttype[0] = THING;
4101 if (PL_nexttoke == 1) {
4102 PL_lex_defer = PL_lex_state;
4103 PL_lex_expect = PL_expect;
4104 PL_lex_state = LEX_KNOWNEXT;
4106 PL_lex_stuff = Nullsv;
4109 if (*SvPV(PL_subname,n_a) == '?') {
4110 sv_setpv(PL_subname,"__ANON__");
4117 LOP(OP_SYSTEM,XREF);
4120 LOP(OP_SYMLINK,XTERM);
4123 LOP(OP_SYSCALL,XTERM);
4126 LOP(OP_SYSOPEN,XTERM);
4129 LOP(OP_SYSSEEK,XTERM);
4132 LOP(OP_SYSREAD,XTERM);
4135 LOP(OP_SYSWRITE,XTERM);
4139 TERM(sublex_start());
4160 LOP(OP_TRUNCATE,XTERM);
4172 yylval.ival = PL_curcop->cop_line;
4176 yylval.ival = PL_curcop->cop_line;
4180 LOP(OP_UNLINK,XTERM);
4186 LOP(OP_UNPACK,XTERM);
4189 LOP(OP_UTIME,XTERM);
4192 if (ckWARN(WARN_OCTAL)) {
4193 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4194 if (*d != '0' && isDIGIT(*d))
4195 yywarn("umask: argument is missing initial 0");
4200 LOP(OP_UNSHIFT,XTERM);
4203 if (PL_expect != XSTATE)
4204 yyerror("\"use\" not allowed in expression");
4207 s = force_version(s);
4208 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4209 PL_nextval[PL_nexttoke].opval = Nullop;
4214 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4215 s = force_version(s);
4228 yylval.ival = PL_curcop->cop_line;
4232 PL_hints |= HINT_BLOCK_SCOPE;
4239 LOP(OP_WAITPID,XTERM);
4247 static char ctl_l[2];
4249 if (ctl_l[0] == '\0')
4250 ctl_l[0] = toCTRL('L');
4251 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4254 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4259 if (PL_expect == XOPERATOR)
4265 yylval.ival = OP_XOR;
4270 TERM(sublex_start());
4276 Perl_keyword(pTHX_ register char *d, I32 len)
4281 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4282 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4283 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4284 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4285 if (strEQ(d,"__END__")) return KEY___END__;
4289 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4294 if (strEQ(d,"and")) return -KEY_and;
4295 if (strEQ(d,"abs")) return -KEY_abs;
4298 if (strEQ(d,"alarm")) return -KEY_alarm;
4299 if (strEQ(d,"atan2")) return -KEY_atan2;
4302 if (strEQ(d,"accept")) return -KEY_accept;
4307 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4310 if (strEQ(d,"bless")) return -KEY_bless;
4311 if (strEQ(d,"bind")) return -KEY_bind;
4312 if (strEQ(d,"binmode")) return -KEY_binmode;
4315 if (strEQ(d,"CORE")) return -KEY_CORE;
4320 if (strEQ(d,"cmp")) return -KEY_cmp;
4321 if (strEQ(d,"chr")) return -KEY_chr;
4322 if (strEQ(d,"cos")) return -KEY_cos;
4325 if (strEQ(d,"chop")) return KEY_chop;
4328 if (strEQ(d,"close")) return -KEY_close;
4329 if (strEQ(d,"chdir")) return -KEY_chdir;
4330 if (strEQ(d,"chomp")) return KEY_chomp;
4331 if (strEQ(d,"chmod")) return -KEY_chmod;
4332 if (strEQ(d,"chown")) return -KEY_chown;
4333 if (strEQ(d,"crypt")) return -KEY_crypt;
4336 if (strEQ(d,"chroot")) return -KEY_chroot;
4337 if (strEQ(d,"caller")) return -KEY_caller;
4340 if (strEQ(d,"connect")) return -KEY_connect;
4343 if (strEQ(d,"closedir")) return -KEY_closedir;
4344 if (strEQ(d,"continue")) return -KEY_continue;
4349 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4354 if (strEQ(d,"do")) return KEY_do;
4357 if (strEQ(d,"die")) return -KEY_die;
4360 if (strEQ(d,"dump")) return -KEY_dump;
4363 if (strEQ(d,"delete")) return KEY_delete;
4366 if (strEQ(d,"defined")) return KEY_defined;
4367 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4370 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4375 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4376 if (strEQ(d,"END")) return KEY_END;
4381 if (strEQ(d,"eq")) return -KEY_eq;
4384 if (strEQ(d,"eof")) return -KEY_eof;
4385 if (strEQ(d,"exp")) return -KEY_exp;
4388 if (strEQ(d,"else")) return KEY_else;
4389 if (strEQ(d,"exit")) return -KEY_exit;
4390 if (strEQ(d,"eval")) return KEY_eval;
4391 if (strEQ(d,"exec")) return -KEY_exec;
4392 if (strEQ(d,"each")) return KEY_each;
4395 if (strEQ(d,"elsif")) return KEY_elsif;
4398 if (strEQ(d,"exists")) return KEY_exists;
4399 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4402 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4403 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4406 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4409 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4410 if (strEQ(d,"endservent")) return -KEY_endservent;
4413 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4420 if (strEQ(d,"for")) return KEY_for;
4423 if (strEQ(d,"fork")) return -KEY_fork;
4426 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4427 if (strEQ(d,"flock")) return -KEY_flock;
4430 if (strEQ(d,"format")) return KEY_format;
4431 if (strEQ(d,"fileno")) return -KEY_fileno;
4434 if (strEQ(d,"foreach")) return KEY_foreach;
4437 if (strEQ(d,"formline")) return -KEY_formline;
4443 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4444 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4448 if (strnEQ(d,"get",3)) {
4453 if (strEQ(d,"ppid")) return -KEY_getppid;
4454 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4457 if (strEQ(d,"pwent")) return -KEY_getpwent;
4458 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4459 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4462 if (strEQ(d,"peername")) return -KEY_getpeername;
4463 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4464 if (strEQ(d,"priority")) return -KEY_getpriority;
4467 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4470 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4474 else if (*d == 'h') {
4475 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4476 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4477 if (strEQ(d,"hostent")) return -KEY_gethostent;
4479 else if (*d == 'n') {
4480 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4481 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4482 if (strEQ(d,"netent")) return -KEY_getnetent;
4484 else if (*d == 's') {
4485 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4486 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4487 if (strEQ(d,"servent")) return -KEY_getservent;
4488 if (strEQ(d,"sockname")) return -KEY_getsockname;
4489 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4491 else if (*d == 'g') {
4492 if (strEQ(d,"grent")) return -KEY_getgrent;
4493 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4494 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4496 else if (*d == 'l') {
4497 if (strEQ(d,"login")) return -KEY_getlogin;
4499 else if (strEQ(d,"c")) return -KEY_getc;
4504 if (strEQ(d,"gt")) return -KEY_gt;
4505 if (strEQ(d,"ge")) return -KEY_ge;
4508 if (strEQ(d,"grep")) return KEY_grep;
4509 if (strEQ(d,"goto")) return KEY_goto;
4510 if (strEQ(d,"glob")) return KEY_glob;
4513 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4518 if (strEQ(d,"hex")) return -KEY_hex;
4521 if (strEQ(d,"INIT")) return KEY_INIT;
4526 if (strEQ(d,"if")) return KEY_if;
4529 if (strEQ(d,"int")) return -KEY_int;
4532 if (strEQ(d,"index")) return -KEY_index;
4533 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4538 if (strEQ(d,"join")) return -KEY_join;
4542 if (strEQ(d,"keys")) return KEY_keys;
4543 if (strEQ(d,"kill")) return -KEY_kill;
4548 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4549 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4555 if (strEQ(d,"lt")) return -KEY_lt;
4556 if (strEQ(d,"le")) return -KEY_le;
4557 if (strEQ(d,"lc")) return -KEY_lc;
4560 if (strEQ(d,"log")) return -KEY_log;
4563 if (strEQ(d,"last")) return KEY_last;
4564 if (strEQ(d,"link")) return -KEY_link;
4565 if (strEQ(d,"lock")) return -KEY_lock;
4568 if (strEQ(d,"local")) return KEY_local;
4569 if (strEQ(d,"lstat")) return -KEY_lstat;
4572 if (strEQ(d,"length")) return -KEY_length;
4573 if (strEQ(d,"listen")) return -KEY_listen;
4576 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4579 if (strEQ(d,"localtime")) return -KEY_localtime;
4585 case 1: return KEY_m;
4587 if (strEQ(d,"my")) return KEY_my;
4590 if (strEQ(d,"map")) return KEY_map;
4593 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4596 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4597 if (strEQ(d,"msgget")) return -KEY_msgget;
4598 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4599 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4604 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4607 if (strEQ(d,"next")) return KEY_next;
4608 if (strEQ(d,"ne")) return -KEY_ne;
4609 if (strEQ(d,"not")) return -KEY_not;
4610 if (strEQ(d,"no")) return KEY_no;
4615 if (strEQ(d,"or")) return -KEY_or;
4618 if (strEQ(d,"ord")) return -KEY_ord;
4619 if (strEQ(d,"oct")) return -KEY_oct;
4620 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4624 if (strEQ(d,"open")) return -KEY_open;
4627 if (strEQ(d,"opendir")) return -KEY_opendir;
4634 if (strEQ(d,"pop")) return KEY_pop;
4635 if (strEQ(d,"pos")) return KEY_pos;
4638 if (strEQ(d,"push")) return KEY_push;
4639 if (strEQ(d,"pack")) return -KEY_pack;
4640 if (strEQ(d,"pipe")) return -KEY_pipe;
4643 if (strEQ(d,"print")) return KEY_print;
4646 if (strEQ(d,"printf")) return KEY_printf;
4649 if (strEQ(d,"package")) return KEY_package;
4652 if (strEQ(d,"prototype")) return KEY_prototype;
4657 if (strEQ(d,"q")) return KEY_q;
4658 if (strEQ(d,"qr")) return KEY_qr;
4659 if (strEQ(d,"qq")) return KEY_qq;
4660 if (strEQ(d,"qw")) return KEY_qw;
4661 if (strEQ(d,"qx")) return KEY_qx;
4663 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4668 if (strEQ(d,"ref")) return -KEY_ref;
4671 if (strEQ(d,"read")) return -KEY_read;
4672 if (strEQ(d,"rand")) return -KEY_rand;
4673 if (strEQ(d,"recv")) return -KEY_recv;
4674 if (strEQ(d,"redo")) return KEY_redo;
4677 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4678 if (strEQ(d,"reset")) return -KEY_reset;
4681 if (strEQ(d,"return")) return KEY_return;
4682 if (strEQ(d,"rename")) return -KEY_rename;
4683 if (strEQ(d,"rindex")) return -KEY_rindex;
4686 if (strEQ(d,"require")) return -KEY_require;
4687 if (strEQ(d,"reverse")) return -KEY_reverse;
4688 if (strEQ(d,"readdir")) return -KEY_readdir;
4691 if (strEQ(d,"readlink")) return -KEY_readlink;
4692 if (strEQ(d,"readline")) return -KEY_readline;
4693 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4696 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4702 case 0: return KEY_s;
4704 if (strEQ(d,"scalar")) return KEY_scalar;
4709 if (strEQ(d,"seek")) return -KEY_seek;
4710 if (strEQ(d,"send")) return -KEY_send;
4713 if (strEQ(d,"semop")) return -KEY_semop;
4716 if (strEQ(d,"select")) return -KEY_select;
4717 if (strEQ(d,"semctl")) return -KEY_semctl;
4718 if (strEQ(d,"semget")) return -KEY_semget;
4721 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4722 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4725 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4726 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4729 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4732 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4733 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4734 if (strEQ(d,"setservent")) return -KEY_setservent;
4737 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4738 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4745 if (strEQ(d,"shift")) return KEY_shift;
4748 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4749 if (strEQ(d,"shmget")) return -KEY_shmget;
4752 if (strEQ(d,"shmread")) return -KEY_shmread;
4755 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4756 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4761 if (strEQ(d,"sin")) return -KEY_sin;
4764 if (strEQ(d,"sleep")) return -KEY_sleep;
4767 if (strEQ(d,"sort")) return KEY_sort;
4768 if (strEQ(d,"socket")) return -KEY_socket;
4769 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4772 if (strEQ(d,"split")) return KEY_split;
4773 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4774 if (strEQ(d,"splice")) return KEY_splice;
4777 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4780 if (strEQ(d,"srand")) return -KEY_srand;
4783 if (strEQ(d,"stat")) return -KEY_stat;
4784 if (strEQ(d,"study")) return KEY_study;
4787 if (strEQ(d,"substr")) return -KEY_substr;
4788 if (strEQ(d,"sub")) return KEY_sub;
4793 if (strEQ(d,"system")) return -KEY_system;
4796 if (strEQ(d,"symlink")) return -KEY_symlink;
4797 if (strEQ(d,"syscall")) return -KEY_syscall;
4798 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4799 if (strEQ(d,"sysread")) return -KEY_sysread;
4800 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4803 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4812 if (strEQ(d,"tr")) return KEY_tr;
4815 if (strEQ(d,"tie")) return KEY_tie;
4818 if (strEQ(d,"tell")) return -KEY_tell;
4819 if (strEQ(d,"tied")) return KEY_tied;
4820 if (strEQ(d,"time")) return -KEY_time;
4823 if (strEQ(d,"times")) return -KEY_times;
4826 if (strEQ(d,"telldir")) return -KEY_telldir;
4829 if (strEQ(d,"truncate")) return -KEY_truncate;
4836 if (strEQ(d,"uc")) return -KEY_uc;
4839 if (strEQ(d,"use")) return KEY_use;
4842 if (strEQ(d,"undef")) return KEY_undef;
4843 if (strEQ(d,"until")) return KEY_until;
4844 if (strEQ(d,"untie")) return KEY_untie;
4845 if (strEQ(d,"utime")) return -KEY_utime;
4846 if (strEQ(d,"umask")) return -KEY_umask;
4849 if (strEQ(d,"unless")) return KEY_unless;
4850 if (strEQ(d,"unpack")) return -KEY_unpack;
4851 if (strEQ(d,"unlink")) return -KEY_unlink;
4854 if (strEQ(d,"unshift")) return KEY_unshift;
4855 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4860 if (strEQ(d,"values")) return -KEY_values;
4861 if (strEQ(d,"vec")) return -KEY_vec;
4866 if (strEQ(d,"warn")) return -KEY_warn;
4867 if (strEQ(d,"wait")) return -KEY_wait;
4870 if (strEQ(d,"while")) return KEY_while;
4871 if (strEQ(d,"write")) return -KEY_write;
4874 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4877 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4882 if (len == 1) return -KEY_x;
4883 if (strEQ(d,"xor")) return -KEY_xor;
4886 if (len == 1) return KEY_y;
4895 S_checkcomma(pTHX_ register char *s, char *name, char *what)
4899 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4900 dTHR; /* only for ckWARN */
4901 if (ckWARN(WARN_SYNTAX)) {
4903 for (w = s+2; *w && level; w++) {
4910 for (; *w && isSPACE(*w); w++) ;
4911 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4912 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
4915 while (s < PL_bufend && isSPACE(*s))
4919 while (s < PL_bufend && isSPACE(*s))
4921 if (isIDFIRST_lazy(s)) {
4923 while (isALNUM_lazy(s))
4925 while (s < PL_bufend && isSPACE(*s))
4930 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
4934 Perl_croak(aTHX_ "No comma allowed after %s", what);
4940 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4943 HV *table = GvHV(PL_hintgv); /* ^H */
4946 bool oldcatch = CATCH_GET;
4951 yyerror("%^H is not defined");
4954 cvp = hv_fetch(table, key, strlen(key), FALSE);
4955 if (!cvp || !SvOK(*cvp)) {
4957 sprintf(buf,"$^H{%s} is not defined", key);
4961 sv_2mortal(sv); /* Parent created it permanently */
4964 pv = sv_2mortal(newSVpvn(s, len));
4966 typesv = sv_2mortal(newSVpv(type, 0));
4968 typesv = &PL_sv_undef;
4970 Zero(&myop, 1, BINOP);
4971 myop.op_last = (OP *) &myop;
4972 myop.op_next = Nullop;
4973 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4975 PUSHSTACKi(PERLSI_OVERLOAD);
4978 PL_op = (OP *) &myop;
4979 if (PERLDB_SUB && PL_curstash != PL_debstash)
4980 PL_op->op_private |= OPpENTERSUB_DB;
4982 Perl_pp_pushmark(aTHX);
4991 if (PL_op = Perl_pp_entersub(aTHX))
4998 CATCH_SET(oldcatch);
5003 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5006 return SvREFCNT_inc(res);
5010 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5012 register char *d = dest;
5013 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5016 Perl_croak(aTHX_ ident_too_long);
5017 if (isALNUM(*s)) /* UTF handled below */
5019 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5024 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5028 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5029 char *t = s + UTF8SKIP(s);
5030 while (*t & 0x80 && is_utf8_mark((U8*)t))
5032 if (d + (t - s) > e)
5033 Perl_croak(aTHX_ ident_too_long);
5034 Copy(s, d, t - s, char);
5047 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5054 if (PL_lex_brackets == 0)
5055 PL_lex_fakebrack = 0;
5059 e = d + destlen - 3; /* two-character token, ending NUL */
5061 while (isDIGIT(*s)) {
5063 Perl_croak(aTHX_ ident_too_long);
5070 Perl_croak(aTHX_ ident_too_long);
5071 if (isALNUM(*s)) /* UTF handled below */
5073 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5078 else if (*s == ':' && s[1] == ':') {
5082 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5083 char *t = s + UTF8SKIP(s);
5084 while (*t & 0x80 && is_utf8_mark((U8*)t))
5086 if (d + (t - s) > e)
5087 Perl_croak(aTHX_ ident_too_long);
5088 Copy(s, d, t - s, char);
5099 if (PL_lex_state != LEX_NORMAL)
5100 PL_lex_state = LEX_INTERPENDMAYBE;
5103 if (*s == '$' && s[1] &&
5104 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5117 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5122 if (isSPACE(s[-1])) {
5125 if (ch != ' ' && ch != '\t') {
5131 if (isIDFIRST_lazy(d)) {
5135 while (e < send && isALNUM_lazy(e) || *e == ':') {
5137 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5140 Copy(s, d, e - s, char);
5145 while ((isALNUM(*s) || *s == ':') && d < e)
5148 Perl_croak(aTHX_ ident_too_long);
5151 while (s < send && (*s == ' ' || *s == '\t')) s++;
5152 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5153 dTHR; /* only for ckWARN */
5154 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5155 char *brack = *s == '[' ? "[...]" : "{...}";
5156 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5157 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5158 funny, dest, brack, funny, dest, brack);
5160 PL_lex_fakebrack = PL_lex_brackets+1;
5162 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5166 /* Handle extended ${^Foo} variables
5167 * 1999-02-27 mjd-perl-patch@plover.com */
5168 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5172 while (isALNUM(*s) && d < e) {
5176 Perl_croak(aTHX_ ident_too_long);
5181 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5182 PL_lex_state = LEX_INTERPEND;
5185 if (PL_lex_state == LEX_NORMAL) {
5186 dTHR; /* only for ckWARN */
5187 if (ckWARN(WARN_AMBIGUOUS) &&
5188 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5190 Perl_warner(aTHX_ WARN_AMBIGUOUS,
5191 "Ambiguous use of %c{%s} resolved to %c%s",
5192 funny, dest, funny, dest);
5197 s = bracket; /* let the parser handle it */
5201 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5202 PL_lex_state = LEX_INTERPEND;
5207 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5212 *pmfl |= PMf_GLOBAL;
5214 *pmfl |= PMf_CONTINUE;
5218 *pmfl |= PMf_MULTILINE;
5220 *pmfl |= PMf_SINGLELINE;
5222 *pmfl |= PMf_EXTENDED;
5226 S_scan_pat(pTHX_ char *start, I32 type)
5231 s = scan_str(start);
5234 SvREFCNT_dec(PL_lex_stuff);
5235 PL_lex_stuff = Nullsv;
5236 Perl_croak(aTHX_ "Search pattern not terminated");
5239 pm = (PMOP*)newPMOP(type, 0);
5240 if (PL_multi_open == '?')
5241 pm->op_pmflags |= PMf_ONCE;
5243 while (*s && strchr("iomsx", *s))
5244 pmflag(&pm->op_pmflags,*s++);
5247 while (*s && strchr("iogcmsx", *s))
5248 pmflag(&pm->op_pmflags,*s++);
5250 pm->op_pmpermflags = pm->op_pmflags;
5252 PL_lex_op = (OP*)pm;
5253 yylval.ival = OP_MATCH;
5258 S_scan_subst(pTHX_ char *start)
5265 yylval.ival = OP_NULL;
5267 s = scan_str(start);
5271 SvREFCNT_dec(PL_lex_stuff);
5272 PL_lex_stuff = Nullsv;
5273 Perl_croak(aTHX_ "Substitution pattern not terminated");
5276 if (s[-1] == PL_multi_open)
5279 first_start = PL_multi_start;
5283 SvREFCNT_dec(PL_lex_stuff);
5284 PL_lex_stuff = Nullsv;
5286 SvREFCNT_dec(PL_lex_repl);
5287 PL_lex_repl = Nullsv;
5288 Perl_croak(aTHX_ "Substitution replacement not terminated");
5290 PL_multi_start = first_start; /* so whole substitution is taken together */
5292 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5298 else if (strchr("iogcmsx", *s))
5299 pmflag(&pm->op_pmflags,*s++);
5306 PL_sublex_info.super_bufptr = s;
5307 PL_sublex_info.super_bufend = PL_bufend;
5309 pm->op_pmflags |= PMf_EVAL;
5310 repl = newSVpvn("",0);
5312 sv_catpv(repl, es ? "eval " : "do ");
5313 sv_catpvn(repl, "{ ", 2);
5314 sv_catsv(repl, PL_lex_repl);
5315 sv_catpvn(repl, " };", 2);
5317 SvREFCNT_dec(PL_lex_repl);
5321 pm->op_pmpermflags = pm->op_pmflags;
5322 PL_lex_op = (OP*)pm;
5323 yylval.ival = OP_SUBST;
5328 S_scan_trans(pTHX_ char *start)
5339 yylval.ival = OP_NULL;
5341 s = scan_str(start);
5344 SvREFCNT_dec(PL_lex_stuff);
5345 PL_lex_stuff = Nullsv;
5346 Perl_croak(aTHX_ "Transliteration pattern not terminated");
5348 if (s[-1] == PL_multi_open)
5354 SvREFCNT_dec(PL_lex_stuff);
5355 PL_lex_stuff = Nullsv;
5357 SvREFCNT_dec(PL_lex_repl);
5358 PL_lex_repl = Nullsv;
5359 Perl_croak(aTHX_ "Transliteration replacement not terminated");
5363 o = newSVOP(OP_TRANS, 0, 0);
5364 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5367 New(803,tbl,256,short);
5368 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5372 complement = del = squash = 0;
5373 while (strchr("cdsCU", *s)) {
5375 complement = OPpTRANS_COMPLEMENT;
5377 del = OPpTRANS_DELETE;
5379 squash = OPpTRANS_SQUASH;
5384 utf8 &= ~OPpTRANS_FROM_UTF;
5386 utf8 |= OPpTRANS_FROM_UTF;
5390 utf8 &= ~OPpTRANS_TO_UTF;
5392 utf8 |= OPpTRANS_TO_UTF;
5395 Perl_croak(aTHX_ "Too many /C and /U options");
5400 o->op_private = del|squash|complement|utf8;
5403 yylval.ival = OP_TRANS;
5408 S_scan_heredoc(pTHX_ register char *s)
5412 I32 op_type = OP_SCALAR;
5419 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5423 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5426 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5427 if (*peek && strchr("`'\"",*peek)) {
5430 s = delimcpy(d, e, s, PL_bufend, term, &len);
5440 if (!isALNUM_lazy(s))
5441 deprecate("bare << to mean <<\"\"");
5442 for (; isALNUM_lazy(s); s++) {
5447 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5448 Perl_croak(aTHX_ "Delimiter for here document is too long");
5451 len = d - PL_tokenbuf;
5452 #ifndef PERL_STRICT_CR
5453 d = strchr(s, '\r');
5457 while (s < PL_bufend) {
5463 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5472 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5477 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5478 herewas = newSVpvn(s,PL_bufend-s);
5480 s--, herewas = newSVpvn(s,d-s);
5481 s += SvCUR(herewas);
5483 tmpstr = NEWSV(87,79);
5484 sv_upgrade(tmpstr, SVt_PVIV);
5489 else if (term == '`') {
5490 op_type = OP_BACKTICK;
5491 SvIVX(tmpstr) = '\\';
5495 PL_multi_start = PL_curcop->cop_line;
5496 PL_multi_open = PL_multi_close = '<';
5497 term = *PL_tokenbuf;
5498 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5499 char *bufptr = PL_sublex_info.super_bufptr;
5500 char *bufend = PL_sublex_info.super_bufend;
5501 char *olds = s - SvCUR(herewas);
5502 s = strchr(bufptr, '\n');
5506 while (s < bufend &&
5507 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5509 PL_curcop->cop_line++;
5512 PL_curcop->cop_line = PL_multi_start;
5513 missingterm(PL_tokenbuf);
5515 sv_setpvn(herewas,bufptr,d-bufptr+1);
5516 sv_setpvn(tmpstr,d+1,s-d);
5518 sv_catpvn(herewas,s,bufend-s);
5519 (void)strcpy(bufptr,SvPVX(herewas));
5526 while (s < PL_bufend &&
5527 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5529 PL_curcop->cop_line++;
5531 if (s >= PL_bufend) {
5532 PL_curcop->cop_line = PL_multi_start;
5533 missingterm(PL_tokenbuf);
5535 sv_setpvn(tmpstr,d+1,s-d);
5537 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5539 sv_catpvn(herewas,s,PL_bufend-s);
5540 sv_setsv(PL_linestr,herewas);
5541 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5542 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5545 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5546 while (s >= PL_bufend) { /* multiple line string? */
5548 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5549 PL_curcop->cop_line = PL_multi_start;
5550 missingterm(PL_tokenbuf);
5552 PL_curcop->cop_line++;
5553 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5554 #ifndef PERL_STRICT_CR
5555 if (PL_bufend - PL_linestart >= 2) {
5556 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5557 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5559 PL_bufend[-2] = '\n';
5561 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5563 else if (PL_bufend[-1] == '\r')
5564 PL_bufend[-1] = '\n';
5566 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5567 PL_bufend[-1] = '\n';
5569 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5570 SV *sv = NEWSV(88,0);
5572 sv_upgrade(sv, SVt_PVMG);
5573 sv_setsv(sv,PL_linestr);
5574 av_store(GvAV(PL_curcop->cop_filegv),
5575 (I32)PL_curcop->cop_line,sv);
5577 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5580 sv_catsv(PL_linestr,herewas);
5581 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5585 sv_catsv(tmpstr,PL_linestr);
5590 PL_multi_end = PL_curcop->cop_line;
5591 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5592 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5593 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5595 SvREFCNT_dec(herewas);
5596 PL_lex_stuff = tmpstr;
5597 yylval.ival = op_type;
5602 takes: current position in input buffer
5603 returns: new position in input buffer
5604 side-effects: yylval and lex_op are set.
5609 <FH> read from filehandle
5610 <pkg::FH> read from package qualified filehandle
5611 <pkg'FH> read from package qualified filehandle
5612 <$fh> read from filehandle in $fh
5618 S_scan_inputsymbol(pTHX_ char *start)
5620 register char *s = start; /* current position in buffer */
5626 d = PL_tokenbuf; /* start of temp holding space */
5627 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5628 end = strchr(s, '\n');
5631 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
5633 /* die if we didn't have space for the contents of the <>,
5634 or if it didn't end, or if we see a newline
5637 if (len >= sizeof PL_tokenbuf)
5638 Perl_croak(aTHX_ "Excessively long <> operator");
5640 Perl_croak(aTHX_ "Unterminated <> operator");
5645 Remember, only scalar variables are interpreted as filehandles by
5646 this code. Anything more complex (e.g., <$fh{$num}>) will be
5647 treated as a glob() call.
5648 This code makes use of the fact that except for the $ at the front,
5649 a scalar variable and a filehandle look the same.
5651 if (*d == '$' && d[1]) d++;
5653 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5654 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5657 /* If we've tried to read what we allow filehandles to look like, and
5658 there's still text left, then it must be a glob() and not a getline.
5659 Use scan_str to pull out the stuff between the <> and treat it
5660 as nothing more than a string.
5663 if (d - PL_tokenbuf != len) {
5664 yylval.ival = OP_GLOB;
5666 s = scan_str(start);
5668 Perl_croak(aTHX_ "Glob not terminated");
5672 /* we're in a filehandle read situation */
5675 /* turn <> into <ARGV> */
5677 (void)strcpy(d,"ARGV");
5679 /* if <$fh>, create the ops to turn the variable into a
5685 /* try to find it in the pad for this block, otherwise find
5686 add symbol table ops
5688 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5689 OP *o = newOP(OP_PADSV, 0);
5691 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5694 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5695 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5696 newUNOP(OP_RV2SV, 0,
5697 newGVOP(OP_GV, 0, gv)));
5699 PL_lex_op->op_flags |= OPf_SPECIAL;
5700 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5701 yylval.ival = OP_NULL;
5704 /* If it's none of the above, it must be a literal filehandle
5705 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5707 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5708 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5709 yylval.ival = OP_NULL;
5718 takes: start position in buffer
5719 returns: position to continue reading from buffer
5720 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5721 updates the read buffer.
5723 This subroutine pulls a string out of the input. It is called for:
5724 q single quotes q(literal text)
5725 ' single quotes 'literal text'
5726 qq double quotes qq(interpolate $here please)
5727 " double quotes "interpolate $here please"
5728 qx backticks qx(/bin/ls -l)
5729 ` backticks `/bin/ls -l`
5730 qw quote words @EXPORT_OK = qw( func() $spam )
5731 m// regexp match m/this/
5732 s/// regexp substitute s/this/that/
5733 tr/// string transliterate tr/this/that/
5734 y/// string transliterate y/this/that/
5735 ($*@) sub prototypes sub foo ($)
5736 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5738 In most of these cases (all but <>, patterns and transliterate)
5739 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5740 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5741 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5744 It skips whitespace before the string starts, and treats the first
5745 character as the delimiter. If the delimiter is one of ([{< then
5746 the corresponding "close" character )]}> is used as the closing
5747 delimiter. It allows quoting of delimiters, and if the string has
5748 balanced delimiters ([{<>}]) it allows nesting.
5750 The lexer always reads these strings into lex_stuff, except in the
5751 case of the operators which take *two* arguments (s/// and tr///)
5752 when it checks to see if lex_stuff is full (presumably with the 1st
5753 arg to s or tr) and if so puts the string into lex_repl.
5758 S_scan_str(pTHX_ char *start)
5761 SV *sv; /* scalar value: string */
5762 char *tmps; /* temp string, used for delimiter matching */
5763 register char *s = start; /* current position in the buffer */
5764 register char term; /* terminating character */
5765 register char *to; /* current position in the sv's data */
5766 I32 brackets = 1; /* bracket nesting level */
5768 /* skip space before the delimiter */
5772 /* mark where we are, in case we need to report errors */
5775 /* after skipping whitespace, the next character is the terminator */
5777 /* mark where we are */
5778 PL_multi_start = PL_curcop->cop_line;
5779 PL_multi_open = term;
5781 /* find corresponding closing delimiter */
5782 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5784 PL_multi_close = term;
5786 /* create a new SV to hold the contents. 87 is leak category, I'm
5787 assuming. 79 is the SV's initial length. What a random number. */
5789 sv_upgrade(sv, SVt_PVIV);
5791 (void)SvPOK_only(sv); /* validate pointer */
5793 /* move past delimiter and try to read a complete string */
5796 /* extend sv if need be */
5797 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5798 /* set 'to' to the next character in the sv's string */
5799 to = SvPVX(sv)+SvCUR(sv);
5801 /* if open delimiter is the close delimiter read unbridle */
5802 if (PL_multi_open == PL_multi_close) {
5803 for (; s < PL_bufend; s++,to++) {
5804 /* embedded newlines increment the current line number */
5805 if (*s == '\n' && !PL_rsfp)
5806 PL_curcop->cop_line++;
5807 /* handle quoted delimiters */
5808 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5811 /* any other quotes are simply copied straight through */
5815 /* terminate when run out of buffer (the for() condition), or
5816 have found the terminator */
5817 else if (*s == term)
5823 /* if the terminator isn't the same as the start character (e.g.,
5824 matched brackets), we have to allow more in the quoting, and
5825 be prepared for nested brackets.
5828 /* read until we run out of string, or we find the terminator */
5829 for (; s < PL_bufend; s++,to++) {
5830 /* embedded newlines increment the line count */
5831 if (*s == '\n' && !PL_rsfp)
5832 PL_curcop->cop_line++;
5833 /* backslashes can escape the open or closing characters */
5834 if (*s == '\\' && s+1 < PL_bufend) {
5835 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5840 /* allow nested opens and closes */
5841 else if (*s == PL_multi_close && --brackets <= 0)
5843 else if (*s == PL_multi_open)
5848 /* terminate the copied string and update the sv's end-of-string */
5850 SvCUR_set(sv, to - SvPVX(sv));
5853 * this next chunk reads more into the buffer if we're not done yet
5856 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5858 #ifndef PERL_STRICT_CR
5859 if (to - SvPVX(sv) >= 2) {
5860 if ((to[-2] == '\r' && to[-1] == '\n') ||
5861 (to[-2] == '\n' && to[-1] == '\r'))
5865 SvCUR_set(sv, to - SvPVX(sv));
5867 else if (to[-1] == '\r')
5870 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5874 /* if we're out of file, or a read fails, bail and reset the current
5875 line marker so we can report where the unterminated string began
5878 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5880 PL_curcop->cop_line = PL_multi_start;
5883 /* we read a line, so increment our line counter */
5884 PL_curcop->cop_line++;
5886 /* update debugger info */
5887 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5888 SV *sv = NEWSV(88,0);
5890 sv_upgrade(sv, SVt_PVMG);
5891 sv_setsv(sv,PL_linestr);
5892 av_store(GvAV(PL_curcop->cop_filegv),
5893 (I32)PL_curcop->cop_line, sv);
5896 /* having changed the buffer, we must update PL_bufend */
5897 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5900 /* at this point, we have successfully read the delimited string */
5902 PL_multi_end = PL_curcop->cop_line;
5905 /* if we allocated too much space, give some back */
5906 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5907 SvLEN_set(sv, SvCUR(sv) + 1);
5908 Renew(SvPVX(sv), SvLEN(sv), char);
5911 /* decide whether this is the first or second quoted string we've read
5924 takes: pointer to position in buffer
5925 returns: pointer to new position in buffer
5926 side-effects: builds ops for the constant in yylval.op
5928 Read a number in any of the formats that Perl accepts:
5930 0(x[0-7A-F]+)|([0-7]+)|(b[01])
5931 [\d_]+(\.[\d_]*)?[Ee](\d+)
5933 Underbars (_) are allowed in decimal numbers. If -w is on,
5934 underbars before a decimal point must be at three digit intervals.
5936 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5939 If it reads a number without a decimal point or an exponent, it will
5940 try converting the number to an integer and see if it can do so
5941 without loss of precision.
5945 Perl_scan_num(pTHX_ char *start)
5947 register char *s = start; /* current position in buffer */
5948 register char *d; /* destination in temp buffer */
5949 register char *e; /* end of temp buffer */
5950 I32 tryiv; /* used to see if it can be an int */
5951 NV value; /* number read, as a double */
5952 SV *sv; /* place to put the converted number */
5953 I32 floatit; /* boolean: int or float? */
5954 char *lastub = 0; /* position of last underbar */
5955 static char number_too_long[] = "Number too long";
5957 /* We use the first character to decide what type of number this is */
5961 Perl_croak(aTHX_ "panic: scan_num");
5963 /* if it starts with a 0, it could be an octal number, a decimal in
5964 0.13 disguise, or a hexadecimal number, or a binary number.
5969 u holds the "number so far"
5970 shift the power of 2 of the base
5971 (hex == 4, octal == 3, binary == 1)
5972 overflowed was the number more than we can hold?
5974 Shift is used when we add a digit. It also serves as an "are
5975 we in octal/hex/binary?" indicator to disallow hex characters
5981 bool overflowed = FALSE;
5987 } else if (s[1] == 'b') {
5991 /* check for a decimal in disguise */
5992 else if (s[1] == '.')
5994 /* so it must be octal */
5999 /* read the rest of the number */
6001 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
6005 /* if we don't mention it, we're done */
6014 /* 8 and 9 are not octal */
6017 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6020 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6024 case '2': case '3': case '4':
6025 case '5': case '6': case '7':
6027 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6031 b = *s++ & 15; /* ASCII digit -> value of digit */
6035 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6036 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6037 /* make sure they said 0x */
6042 /* Prepare to put the digit we have onto the end
6043 of the number so far. We check for overflows.
6047 n = u << shift; /* make room for the digit */
6048 if (!overflowed && (n >> shift) != u
6049 && !(PL_hints & HINT_NEW_BINARY))
6051 if (ckWARN_d(WARN_UNSAFE))
6052 Perl_warner(aTHX_ WARN_UNSAFE,
6053 "Integer overflow in %s number",
6054 (shift == 4) ? "hex"
6055 : ((shift == 3) ? "octal" : "binary"));
6058 u = n | b; /* add the digit to the end */
6063 /* if we get here, we had success: make a scalar value from
6069 if ( PL_hints & HINT_NEW_BINARY)
6070 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6075 handle decimal numbers.
6076 we're also sent here when we read a 0 as the first digit
6078 case '1': case '2': case '3': case '4': case '5':
6079 case '6': case '7': case '8': case '9': case '.':
6082 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6085 /* read next group of digits and _ and copy into d */
6086 while (isDIGIT(*s) || *s == '_') {
6087 /* skip underscores, checking for misplaced ones
6091 dTHR; /* only for ckWARN */
6092 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6093 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6097 /* check for end of fixed-length buffer */
6099 Perl_croak(aTHX_ number_too_long);
6100 /* if we're ok, copy the character */
6105 /* final misplaced underbar check */
6106 if (lastub && s - lastub != 3) {
6108 if (ckWARN(WARN_SYNTAX))
6109 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6112 /* read a decimal portion if there is one. avoid
6113 3..5 being interpreted as the number 3. followed
6116 if (*s == '.' && s[1] != '.') {
6120 /* copy, ignoring underbars, until we run out of
6121 digits. Note: no misplaced underbar checks!
6123 for (; isDIGIT(*s) || *s == '_'; s++) {
6124 /* fixed length buffer check */
6126 Perl_croak(aTHX_ number_too_long);
6132 /* read exponent part, if present */
6133 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6137 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6138 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6140 /* allow positive or negative exponent */
6141 if (*s == '+' || *s == '-')
6144 /* read digits of exponent (no underbars :-) */
6145 while (isDIGIT(*s)) {
6147 Perl_croak(aTHX_ number_too_long);
6152 /* terminate the string */
6155 /* make an sv from the string */
6158 value = Atof(PL_tokenbuf);
6161 See if we can make do with an integer value without loss of
6162 precision. We use I_V to cast to an int, because some
6163 compilers have issues. Then we try casting it back and see
6164 if it was the same. We only do this if we know we
6165 specifically read an integer.
6167 Note: if floatit is true, then we don't need to do the
6171 if (!floatit && (NV)tryiv == value)
6172 sv_setiv(sv, tryiv);
6174 sv_setnv(sv, value);
6175 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6176 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6177 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6181 /* make the op for the constant and return */
6183 yylval.opval = newSVOP(OP_CONST, 0, sv);
6189 S_scan_formline(pTHX_ register char *s)
6194 SV *stuff = newSVpvn("",0);
6195 bool needargs = FALSE;
6198 if (*s == '.' || *s == '}') {
6200 #ifdef PERL_STRICT_CR
6201 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6203 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6205 if (*t == '\n' || t == PL_bufend)
6208 if (PL_in_eval && !PL_rsfp) {
6209 eol = strchr(s,'\n');
6214 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6216 for (t = s; t < eol; t++) {
6217 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6219 goto enough; /* ~~ must be first line in formline */
6221 if (*t == '@' || *t == '^')
6224 sv_catpvn(stuff, s, eol-s);
6228 s = filter_gets(PL_linestr, PL_rsfp, 0);
6229 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6230 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6233 yyerror("Format not terminated");
6243 PL_lex_state = LEX_NORMAL;
6244 PL_nextval[PL_nexttoke].ival = 0;
6248 PL_lex_state = LEX_FORMLINE;
6249 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6251 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6255 SvREFCNT_dec(stuff);
6256 PL_lex_formbrack = 0;
6267 PL_cshlen = strlen(PL_cshname);
6272 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6275 I32 oldsavestack_ix = PL_savestack_ix;
6276 CV* outsidecv = PL_compcv;
6280 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6282 save_I32(&PL_subline);
6283 save_item(PL_subname);
6285 SAVESPTR(PL_curpad);
6286 SAVESPTR(PL_comppad);
6287 SAVESPTR(PL_comppad_name);
6288 SAVESPTR(PL_compcv);
6289 SAVEI32(PL_comppad_name_fill);
6290 SAVEI32(PL_min_intro_pending);
6291 SAVEI32(PL_max_intro_pending);
6292 SAVEI32(PL_pad_reset_pending);
6294 PL_compcv = (CV*)NEWSV(1104,0);
6295 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6296 CvFLAGS(PL_compcv) |= flags;
6298 PL_comppad = newAV();
6299 av_push(PL_comppad, Nullsv);
6300 PL_curpad = AvARRAY(PL_comppad);
6301 PL_comppad_name = newAV();
6302 PL_comppad_name_fill = 0;
6303 PL_min_intro_pending = 0;
6305 PL_subline = PL_curcop->cop_line;
6307 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6308 PL_curpad[0] = (SV*)newAV();
6309 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6310 #endif /* USE_THREADS */
6312 comppadlist = newAV();
6313 AvREAL_off(comppadlist);
6314 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6315 av_store(comppadlist, 1, (SV*)PL_comppad);
6317 CvPADLIST(PL_compcv) = comppadlist;
6318 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6320 CvOWNER(PL_compcv) = 0;
6321 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6322 MUTEX_INIT(CvMUTEXP(PL_compcv));
6323 #endif /* USE_THREADS */
6325 return oldsavestack_ix;
6329 Perl_yywarn(pTHX_ char *s)
6333 PL_in_eval |= EVAL_WARNONLY;
6335 PL_in_eval &= ~EVAL_WARNONLY;
6340 Perl_yyerror(pTHX_ char *s)
6344 char *context = NULL;
6348 if (!yychar || (yychar == ';' && !PL_rsfp))
6350 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6351 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6352 while (isSPACE(*PL_oldoldbufptr))
6354 context = PL_oldoldbufptr;
6355 contlen = PL_bufptr - PL_oldoldbufptr;
6357 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6358 PL_oldbufptr != PL_bufptr) {
6359 while (isSPACE(*PL_oldbufptr))
6361 context = PL_oldbufptr;
6362 contlen = PL_bufptr - PL_oldbufptr;
6364 else if (yychar > 255)
6365 where = "next token ???";
6366 else if ((yychar & 127) == 127) {
6367 if (PL_lex_state == LEX_NORMAL ||
6368 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6369 where = "at end of line";
6370 else if (PL_lex_inpat)
6371 where = "within pattern";
6373 where = "within string";
6376 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6378 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6379 else if (isPRINT_LC(yychar))
6380 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6382 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6383 where = SvPVX(where_sv);
6385 msg = sv_2mortal(newSVpv(s, 0));
6386 Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6387 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6389 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6391 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6392 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6393 Perl_sv_catpvf(aTHX_ msg,
6394 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6395 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6398 if (PL_in_eval & EVAL_WARNONLY)
6399 Perl_warn(aTHX_ "%_", msg);
6400 else if (PL_in_eval)
6401 sv_catsv(ERRSV, msg);
6403 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6404 if (++PL_error_count >= 10)
6405 Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6407 PL_in_my_stash = Nullhv;
6418 restore_rsfp(pTHXo_ void *f)
6420 PerlIO *fp = (PerlIO*)f;
6422 if (PL_rsfp == PerlIO_stdin())
6423 PerlIO_clearerr(PL_rsfp);
6424 else if (PL_rsfp && (PL_rsfp != fp))
6425 PerlIO_close(PL_rsfp);
6430 restore_expect(pTHXo_ void *e)
6432 /* a safe way to store a small integer in a pointer */
6433 PL_expect = (expectation)((char *)e - PL_tokenbuf);
6437 restore_lex_expect(pTHXo_ void *e)
6439 /* a safe way to store a small integer in a pointer */
6440 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);