3 * Copyright (c) 1991-1997, 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
17 #define yychar PL_yychar
18 #define yylval PL_yylval
21 static void check_uni _((void));
22 static void force_next _((I32 type));
23 static char *force_version _((char *start));
24 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
25 static SV *tokeq _((SV *sv));
26 static char *scan_const _((char *start));
27 static char *scan_formline _((char *s));
28 static char *scan_heredoc _((char *s));
29 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
31 static char *scan_inputsymbol _((char *start));
32 static char *scan_pat _((char *start, I32 type));
33 static char *scan_str _((char *start));
34 static char *scan_subst _((char *start));
35 static char *scan_trans _((char *start));
36 static char *scan_word _((char *s, char *dest, STRLEN destlen,
37 int allow_package, STRLEN *slp));
38 static char *skipspace _((char *s));
39 static void checkcomma _((char *s, char *name, char *what));
40 static void force_ident _((char *s, int kind));
41 static void incline _((char *s));
42 static int intuit_method _((char *s, GV *gv));
43 static int intuit_more _((char *s));
44 static I32 lop _((I32 f, expectation x, char *s));
45 static void missingterm _((char *s));
46 static void no_op _((char *what, char *s));
47 static void set_csh _((void));
48 static I32 sublex_done _((void));
49 static I32 sublex_push _((void));
50 static I32 sublex_start _((void));
52 static int uni _((I32 f, char *s));
54 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
55 static void restore_rsfp _((void *f));
56 static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
57 static void restore_expect _((void *e));
58 static void restore_lex_expect _((void *e));
59 #endif /* PERL_OBJECT */
61 static char ident_too_long[] = "Identifier too long";
63 #define UTF (PL_hints & HINT_UTF8)
65 /* The following are arranged oddly so that the guard on the switch statement
66 * can get by with a single comparison (if the compiler is smart enough).
69 /* #define LEX_NOTPARSING 11 is done in perl.h. */
72 #define LEX_INTERPNORMAL 9
73 #define LEX_INTERPCASEMOD 8
74 #define LEX_INTERPPUSH 7
75 #define LEX_INTERPSTART 6
76 #define LEX_INTERPEND 5
77 #define LEX_INTERPENDMAYBE 4
78 #define LEX_INTERPCONCAT 3
79 #define LEX_INTERPCONST 2
80 #define LEX_FORMLINE 1
81 #define LEX_KNOWNEXT 0
90 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
92 # include <unistd.h> /* Needed for execv() */
100 #ifdef USE_PURE_BISON
101 YYSTYPE* yylval_pointer = NULL;
102 int* yychar_pointer = NULL;
107 #define yylval (*yylval_pointer)
108 #define yychar (*yychar_pointer)
109 #define YYLEXPARAM yylval_pointer,yychar_pointer
114 #include "keywords.h"
119 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
121 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
122 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
123 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
124 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
125 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
126 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
127 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
128 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
129 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
130 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
131 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
132 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
133 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
134 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
135 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
136 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
137 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
138 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
139 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
140 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
142 /* This bit of chicanery makes a unary function followed by
143 * a parenthesis into a function with one argument, highest precedence.
145 #define UNI(f) return(yylval.ival = f, \
148 PL_last_uni = PL_oldbufptr, \
149 PL_last_lop_op = f, \
150 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
152 #define UNIBRACK(f) return(yylval.ival = f, \
154 PL_last_uni = PL_oldbufptr, \
155 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
157 /* grandfather return to old style */
158 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
163 if (*PL_bufptr == '=') {
165 if (toketype == ANDAND)
166 yylval.ival = OP_ANDASSIGN;
167 else if (toketype == OROR)
168 yylval.ival = OP_ORASSIGN;
175 no_op(char *what, char *s)
177 char *oldbp = PL_bufptr;
178 bool is_first = (PL_oldbufptr == PL_linestart);
181 yywarn(form("%s found where operator expected", what));
183 warn("\t(Missing semicolon on previous line?)\n");
184 else if (PL_oldoldbufptr && isIDFIRST(*PL_oldoldbufptr)) {
186 for (t = PL_oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
187 if (t < PL_bufptr && isSPACE(*t))
188 warn("\t(Do you need to predeclare %.*s?)\n",
189 t - PL_oldoldbufptr, PL_oldoldbufptr);
193 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
203 char *nl = strrchr(s,'\n');
209 iscntrl(PL_multi_close)
211 PL_multi_close < 32 || PL_multi_close == 127
215 tmpbuf[1] = toCTRL(PL_multi_close);
221 *tmpbuf = PL_multi_close;
225 q = strchr(s,'"') ? '\'' : '"';
226 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
233 if (ckWARN(WARN_DEPRECATED))
234 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
240 deprecate("comma-less variable list");
246 win32_textfilter(int idx, SV *sv, int maxlen)
248 I32 count = FILTER_READ(idx+1, sv, maxlen);
249 if (count > 0 && !maxlen)
250 win32_strip_return(sv);
258 utf16_textfilter(int idx, SV *sv, int maxlen)
260 I32 count = FILTER_READ(idx+1, sv, maxlen);
264 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
265 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
266 sv_usepvn(sv, (char*)tmps, tend - tmps);
273 utf16rev_textfilter(int idx, SV *sv, int maxlen)
275 I32 count = FILTER_READ(idx+1, sv, maxlen);
279 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
280 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
281 sv_usepvn(sv, (char*)tmps, tend - tmps);
296 SAVEI32(PL_lex_dojoin);
297 SAVEI32(PL_lex_brackets);
298 SAVEI32(PL_lex_fakebrack);
299 SAVEI32(PL_lex_casemods);
300 SAVEI32(PL_lex_starts);
301 SAVEI32(PL_lex_state);
302 SAVESPTR(PL_lex_inpat);
303 SAVEI32(PL_lex_inwhat);
304 SAVEI16(PL_curcop->cop_line);
307 SAVEPPTR(PL_oldbufptr);
308 SAVEPPTR(PL_oldoldbufptr);
309 SAVEPPTR(PL_linestart);
310 SAVESPTR(PL_linestr);
311 SAVEPPTR(PL_lex_brackstack);
312 SAVEPPTR(PL_lex_casestack);
313 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
314 SAVESPTR(PL_lex_stuff);
315 SAVEI32(PL_lex_defer);
316 SAVESPTR(PL_lex_repl);
317 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
318 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
320 PL_lex_state = LEX_NORMAL;
324 PL_lex_fakebrack = 0;
325 New(899, PL_lex_brackstack, 120, char);
326 New(899, PL_lex_casestack, 12, char);
327 SAVEFREEPV(PL_lex_brackstack);
328 SAVEFREEPV(PL_lex_casestack);
330 *PL_lex_casestack = '\0';
333 PL_lex_stuff = Nullsv;
334 PL_lex_repl = Nullsv;
338 if (SvREADONLY(PL_linestr))
339 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
340 s = SvPV(PL_linestr, len);
341 if (len && s[len-1] != ';') {
342 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
343 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
344 sv_catpvn(PL_linestr, "\n;", 2);
346 SvTEMP_off(PL_linestr);
347 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
348 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
350 PL_rs = newSVpv("\n", 1);
357 PL_doextract = FALSE;
361 restore_rsfp(void *f)
363 PerlIO *fp = (PerlIO*)f;
365 if (PL_rsfp == PerlIO_stdin())
366 PerlIO_clearerr(PL_rsfp);
367 else if (PL_rsfp && (PL_rsfp != fp))
368 PerlIO_close(PL_rsfp);
373 restore_expect(void *e)
375 /* a safe way to store a small integer in a pointer */
376 PL_expect = (expectation)((char *)e - PL_tokenbuf);
380 restore_lex_expect(void *e)
382 /* a safe way to store a small integer in a pointer */
383 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
395 PL_curcop->cop_line++;
398 while (*s == ' ' || *s == '\t') s++;
399 if (strnEQ(s, "line ", 5)) {
408 while (*s == ' ' || *s == '\t')
410 if (*s == '"' && (t = strchr(s+1, '"')))
414 return; /* false alarm */
415 for (t = s; !isSPACE(*t); t++) ;
420 PL_curcop->cop_filegv = gv_fetchfile(s);
422 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
424 PL_curcop->cop_line = atoi(n)-1;
428 skipspace(register char *s)
431 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
432 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
438 while (s < PL_bufend && isSPACE(*s))
440 if (s < PL_bufend && *s == '#') {
441 while (s < PL_bufend && *s != '\n')
446 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
448 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
449 if (PL_minus_n || PL_minus_p) {
450 sv_setpv(PL_linestr,PL_minus_p ?
451 ";}continue{print or die qq(-p destination: $!\\n)" :
453 sv_catpv(PL_linestr,";}");
454 PL_minus_n = PL_minus_p = 0;
457 sv_setpv(PL_linestr,";");
458 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
459 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
460 if (PL_preprocess && !PL_in_eval)
461 (void)PerlProc_pclose(PL_rsfp);
462 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
463 PerlIO_clearerr(PL_rsfp);
465 (void)PerlIO_close(PL_rsfp);
469 PL_linestart = PL_bufptr = s + prevlen;
470 PL_bufend = s + SvCUR(PL_linestr);
473 if (PERLDB_LINE && PL_curstash != PL_debstash) {
474 SV *sv = NEWSV(85,0);
476 sv_upgrade(sv, SVt_PVMG);
477 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
478 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
489 if (PL_oldoldbufptr != PL_last_uni)
491 while (isSPACE(*PL_last_uni))
493 for (s = PL_last_uni; isALNUM(*s) || *s == '-'; s++) ;
494 if ((t = strchr(s, '(')) && t < PL_bufptr)
498 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
505 #define UNI(f) return uni(f,s)
513 PL_last_uni = PL_oldbufptr;
524 #endif /* CRIPPLED_CC */
526 #define LOP(f,x) return lop(f,x,s)
529 lop(I32 f, expectation x, char *s)
536 PL_last_lop = PL_oldbufptr;
552 PL_nexttype[PL_nexttoke] = type;
554 if (PL_lex_state != LEX_KNOWNEXT) {
555 PL_lex_defer = PL_lex_state;
556 PL_lex_expect = PL_expect;
557 PL_lex_state = LEX_KNOWNEXT;
562 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
567 start = skipspace(start);
570 (allow_pack && *s == ':') ||
571 (allow_initial_tick && *s == '\'') )
573 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
574 if (check_keyword && keyword(PL_tokenbuf, len))
576 if (token == METHOD) {
581 PL_expect = XOPERATOR;
586 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
587 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
594 force_ident(register char *s, int kind)
597 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
598 PL_nextval[PL_nexttoke].opval = o;
601 dTHR; /* just for in_eval */
602 o->op_private = OPpCONST_ENTERED;
603 /* XXX see note in pp_entereval() for why we forgo typo
604 warnings if the symbol must be introduced in an eval.
606 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
607 kind == '$' ? SVt_PV :
608 kind == '@' ? SVt_PVAV :
609 kind == '%' ? SVt_PVHV :
617 force_version(char *s)
619 OP *version = Nullop;
623 /* default VERSION number -- GBARR */
628 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
629 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
631 /* real VERSION number -- GBARR */
632 version = yylval.opval;
636 /* NOTE: The parser sees the package name and the VERSION swapped */
637 PL_nextval[PL_nexttoke].opval = version;
655 s = SvPV_force(sv, len);
659 while (s < send && *s != '\\')
664 if ( PL_hints & HINT_NEW_STRING )
665 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
668 if (s + 1 < send && (s[1] == '\\'))
669 s++; /* all that, just for this */
674 SvCUR_set(sv, d - SvPVX(sv));
676 if ( PL_hints & HINT_NEW_STRING )
677 return new_constant(NULL, 0, "q", sv, pv, "q");
684 register I32 op_type = yylval.ival;
686 if (op_type == OP_NULL) {
687 yylval.opval = PL_lex_op;
691 if (op_type == OP_CONST || op_type == OP_READLINE) {
692 SV *sv = tokeq(PL_lex_stuff);
694 if (SvTYPE(sv) == SVt_PVIV) {
695 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
701 nsv = newSVpv(p, len);
705 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
706 PL_lex_stuff = Nullsv;
710 PL_sublex_info.super_state = PL_lex_state;
711 PL_sublex_info.sub_inwhat = op_type;
712 PL_sublex_info.sub_op = PL_lex_op;
713 PL_lex_state = LEX_INTERPPUSH;
717 yylval.opval = PL_lex_op;
731 PL_lex_state = PL_sublex_info.super_state;
732 SAVEI32(PL_lex_dojoin);
733 SAVEI32(PL_lex_brackets);
734 SAVEI32(PL_lex_fakebrack);
735 SAVEI32(PL_lex_casemods);
736 SAVEI32(PL_lex_starts);
737 SAVEI32(PL_lex_state);
738 SAVESPTR(PL_lex_inpat);
739 SAVEI32(PL_lex_inwhat);
740 SAVEI16(PL_curcop->cop_line);
742 SAVEPPTR(PL_oldbufptr);
743 SAVEPPTR(PL_oldoldbufptr);
744 SAVEPPTR(PL_linestart);
745 SAVESPTR(PL_linestr);
746 SAVEPPTR(PL_lex_brackstack);
747 SAVEPPTR(PL_lex_casestack);
749 PL_linestr = PL_lex_stuff;
750 PL_lex_stuff = Nullsv;
752 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
753 PL_bufend += SvCUR(PL_linestr);
754 SAVEFREESV(PL_linestr);
756 PL_lex_dojoin = FALSE;
758 PL_lex_fakebrack = 0;
759 New(899, PL_lex_brackstack, 120, char);
760 New(899, PL_lex_casestack, 12, char);
761 SAVEFREEPV(PL_lex_brackstack);
762 SAVEFREEPV(PL_lex_casestack);
764 *PL_lex_casestack = '\0';
766 PL_lex_state = LEX_INTERPCONCAT;
767 PL_curcop->cop_line = PL_multi_start;
769 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
770 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
771 PL_lex_inpat = PL_sublex_info.sub_op;
773 PL_lex_inpat = Nullop;
781 if (!PL_lex_starts++) {
782 PL_expect = XOPERATOR;
783 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
787 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
788 PL_lex_state = LEX_INTERPCASEMOD;
789 return yylex(YYLEXPARAM);
792 /* Is there a right-hand side to take care of? */
793 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
794 PL_linestr = PL_lex_repl;
796 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
797 PL_bufend += SvCUR(PL_linestr);
798 SAVEFREESV(PL_linestr);
799 PL_lex_dojoin = FALSE;
801 PL_lex_fakebrack = 0;
803 *PL_lex_casestack = '\0';
805 if (SvCOMPILED(PL_lex_repl)) {
806 PL_lex_state = LEX_INTERPNORMAL;
810 PL_lex_state = LEX_INTERPCONCAT;
811 PL_lex_repl = Nullsv;
816 PL_bufend = SvPVX(PL_linestr);
817 PL_bufend += SvCUR(PL_linestr);
818 PL_expect = XOPERATOR;
826 Extracts a pattern, double-quoted string, or transliteration. This
829 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
830 processing a pattern (PL_lex_inpat is true), a transliteration
831 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
833 Returns a pointer to the character scanned up to. Iff this is
834 advanced from the start pointer supplied (ie if anything was
835 successfully parsed), will leave an OP for the substring scanned
836 in yylval. Caller must intuit reason for not parsing further
837 by looking at the next characters herself.
841 double-quoted style: \r and \n
842 regexp special ones: \D \s
844 backrefs: \1 (deprecated in substitution replacements)
845 case and quoting: \U \Q \E
846 stops on @ and $, but not for $ as tail anchor
849 characters are VERY literal, except for - not at the start or end
850 of the string, which indicates a range. scan_const expands the
851 range to the full set of intermediate characters.
853 In double-quoted strings:
855 double-quoted style: \r and \n
857 backrefs: \1 (deprecated)
858 case and quoting: \U \Q \E
861 scan_const does *not* construct ops to handle interpolated strings.
862 It stops processing as soon as it finds an embedded $ or @ variable
863 and leaves it to the caller to work out what's going on.
865 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
867 $ in pattern could be $foo or could be tail anchor. Assumption:
868 it's a tail anchor if $ is the last thing in the string, or if it's
869 followed by one of ")| \n\t"
871 \1 (backreferences) are turned into $1
873 The structure of the code is
874 while (there's a character to process) {
875 handle transliteration ranges
877 skip # initiated comments in //x patterns
878 check for embedded @foo
879 check for embedded scalars
881 leave intact backslashes from leave (below)
882 deprecate \1 in strings and sub replacements
883 handle string-changing backslashes \l \U \Q \E, etc.
884 switch (what was escaped) {
885 handle - in a transliteration (becomes a literal -)
886 handle \132 octal characters
887 handle 0x15 hex characters
888 handle \cV (control V)
889 handle printf backslashes (\f, \r, \n, etc)
892 } (end while character to read)
897 scan_const(char *start)
899 register char *send = PL_bufend; /* end of the constant */
900 SV *sv = NEWSV(93, send - start); /* sv for the constant */
901 register char *s = start; /* start of the constant */
902 register char *d = SvPVX(sv); /* destination for copies */
903 bool dorange = FALSE; /* are we in a translit range? */
905 I32 utf = PL_lex_inwhat == OP_TRANS
906 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
908 I32 thisutf = PL_lex_inwhat == OP_TRANS
909 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
912 /* leaveit is the set of acceptably-backslashed characters */
915 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
918 while (s < send || dorange) {
919 /* get transliterations out of the way (they're most literal) */
920 if (PL_lex_inwhat == OP_TRANS) {
921 /* expand a range A-Z to the full set of characters. AIE! */
923 I32 i; /* current expanded character */
924 I32 min; /* first character in range */
925 I32 max; /* last character in range */
927 i = d - SvPVX(sv); /* remember current offset */
928 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
929 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
930 d -= 2; /* eat the first char and the - */
932 min = (U8)*d; /* first char in range */
933 max = (U8)d[1]; /* last char in range */
936 if ((isLOWER(min) && isLOWER(max)) ||
937 (isUPPER(min) && isUPPER(max))) {
939 for (i = min; i <= max; i++)
943 for (i = min; i <= max; i++)
950 for (i = min; i <= max; i++)
953 /* mark the range as done, and continue */
958 /* range begins (ignore - as first or last char) */
959 else if (*s == '-' && s+1 < send && s != start) {
961 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
970 /* if we get here, we're not doing a transliteration */
972 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
973 except for the last char, which will be done separately. */
974 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
976 while (s < send && *s != ')')
978 } else if (s[2] == '{'
979 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
981 char *regparse = s + (s[2] == '{' ? 3 : 4);
984 while (count && (c = *regparse)) {
985 if (c == '\\' && regparse[1])
993 if (*regparse != ')') {
994 regparse--; /* Leave one char for continuation. */
995 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1002 /* likewise skip #-initiated comments in //x patterns */
1003 else if (*s == '#' && PL_lex_inpat &&
1004 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1005 while (s+1 < send && *s != '\n')
1009 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1010 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
1013 /* check for embedded scalars. only stop if we're sure it's a
1016 else if (*s == '$') {
1017 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1019 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1020 break; /* in regexp, $ might be tail anchor */
1023 /* (now in tr/// code again) */
1025 if (*s & 0x80 && thisutf) {
1026 dTHR; /* only for ckWARN */
1027 if (ckWARN(WARN_UTF8)) {
1028 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1038 if (*s == '\\' && s+1 < send) {
1041 /* some backslashes we leave behind */
1042 if (*s && strchr(leaveit, *s)) {
1048 /* deprecate \1 in strings and substitution replacements */
1049 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1050 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1052 dTHR; /* only for ckWARN */
1053 if (ckWARN(WARN_SYNTAX))
1054 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1059 /* string-change backslash escapes */
1060 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1065 /* if we get here, it's either a quoted -, or a digit */
1068 /* quoted - in transliterations */
1070 if (PL_lex_inwhat == OP_TRANS) {
1075 /* default action is to copy the quoted character */
1080 /* \132 indicates an octal constant */
1081 case '0': case '1': case '2': case '3':
1082 case '4': case '5': case '6': case '7':
1083 *d++ = scan_oct(s, 3, &len);
1087 /* \x24 indicates a hex constant */
1091 char* e = strchr(s, '}');
1094 yyerror("Missing right brace on \\x{}");
1099 if (ckWARN(WARN_UTF8))
1101 "Use of \\x{} without utf8 declaration");
1103 /* note: utf always shorter than hex */
1104 d = (char*)uv_to_utf8((U8*)d,
1105 scan_hex(s + 1, e - s - 1, &len));
1110 UV uv = (UV)scan_hex(s, 2, &len);
1111 if (utf && PL_lex_inwhat == OP_TRANS &&
1112 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1114 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1117 if (uv >= 127 && UTF) {
1119 if (ckWARN(WARN_UTF8))
1121 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1130 /* \c is a control character */
1144 /* printf-style backslashes, formfeeds, newlines, etc */
1170 } /* end if (backslash) */
1173 } /* while loop to process each character */
1175 /* terminate the string and set up the sv */
1177 SvCUR_set(sv, d - SvPVX(sv));
1180 /* shrink the sv if we allocated more than we used */
1181 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1182 SvLEN_set(sv, SvCUR(sv) + 1);
1183 Renew(SvPVX(sv), SvLEN(sv), char);
1186 /* return the substring (via yylval) only if we parsed anything */
1187 if (s > PL_bufptr) {
1188 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1189 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1191 ( PL_lex_inwhat == OP_TRANS
1193 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1196 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1202 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1204 intuit_more(register char *s)
1206 if (PL_lex_brackets)
1208 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1210 if (*s != '{' && *s != '[')
1215 /* In a pattern, so maybe we have {n,m}. */
1232 /* On the other hand, maybe we have a character class */
1235 if (*s == ']' || *s == '^')
1238 int weight = 2; /* let's weigh the evidence */
1240 unsigned char un_char = 255, last_un_char;
1241 char *send = strchr(s,']');
1242 char tmpbuf[sizeof PL_tokenbuf * 4];
1244 if (!send) /* has to be an expression */
1247 Zero(seen,256,char);
1250 else if (isDIGIT(*s)) {
1252 if (isDIGIT(s[1]) && s[2] == ']')
1258 for (; s < send; s++) {
1259 last_un_char = un_char;
1260 un_char = (unsigned char)*s;
1265 weight -= seen[un_char] * 10;
1266 if (isALNUM(s[1])) {
1267 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1268 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1273 else if (*s == '$' && s[1] &&
1274 strchr("[#!%*<>()-=",s[1])) {
1275 if (/*{*/ strchr("])} =",s[2]))
1284 if (strchr("wds]",s[1]))
1286 else if (seen['\''] || seen['"'])
1288 else if (strchr("rnftbxcav",s[1]))
1290 else if (isDIGIT(s[1])) {
1292 while (s[1] && isDIGIT(s[1]))
1302 if (strchr("aA01! ",last_un_char))
1304 if (strchr("zZ79~",s[1]))
1306 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1307 weight -= 5; /* cope with negative subscript */
1310 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1311 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1316 if (keyword(tmpbuf, d - tmpbuf))
1319 if (un_char == last_un_char + 1)
1321 weight -= seen[un_char];
1326 if (weight >= 0) /* probably a character class */
1334 intuit_method(char *start, GV *gv)
1336 char *s = start + (*start == '$');
1337 char tmpbuf[sizeof PL_tokenbuf];
1345 if ((cv = GvCVu(gv))) {
1346 char *proto = SvPVX(cv);
1356 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1357 if (*start == '$') {
1358 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1363 return *s == '(' ? FUNCMETH : METHOD;
1365 if (!keyword(tmpbuf, len)) {
1366 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1371 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1372 if (indirgv && GvCVu(indirgv))
1374 /* filehandle or package name makes it a method */
1375 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1377 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1378 return 0; /* no assumptions -- "=>" quotes bearword */
1380 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1382 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1386 return *s == '(' ? FUNCMETH : METHOD;
1396 char *pdb = PerlEnv_getenv("PERL5DB");
1400 SETERRNO(0,SS$_NORMAL);
1401 return "BEGIN { require 'perl5db.pl' }";
1407 /* Encoded script support. filter_add() effectively inserts a
1408 * 'pre-processing' function into the current source input stream.
1409 * Note that the filter function only applies to the current source file
1410 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1412 * The datasv parameter (which may be NULL) can be used to pass
1413 * private data to this instance of the filter. The filter function
1414 * can recover the SV using the FILTER_DATA macro and use it to
1415 * store private buffers and state information.
1417 * The supplied datasv parameter is upgraded to a PVIO type
1418 * and the IoDIRP field is used to store the function pointer.
1419 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1420 * private use must be set using malloc'd pointers.
1422 static int filter_debug = 0;
1425 filter_add(filter_t funcp, SV *datasv)
1427 if (!funcp){ /* temporary handy debugging hack to be deleted */
1428 filter_debug = atoi((char*)datasv);
1431 if (!PL_rsfp_filters)
1432 PL_rsfp_filters = newAV();
1434 datasv = NEWSV(255,0);
1435 if (!SvUPGRADE(datasv, SVt_PVIO))
1436 die("Can't upgrade filter_add data to SVt_PVIO");
1437 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1439 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1440 av_unshift(PL_rsfp_filters, 1);
1441 av_store(PL_rsfp_filters, 0, datasv) ;
1446 /* Delete most recently added instance of this filter function. */
1448 filter_del(filter_t funcp)
1451 warn("filter_del func %p", funcp);
1452 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1454 /* if filter is on top of stack (usual case) just pop it off */
1455 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1456 sv_free(av_pop(PL_rsfp_filters));
1460 /* we need to search for the correct entry and clear it */
1461 die("filter_del can only delete in reverse order (currently)");
1465 /* Invoke the n'th filter function for the current rsfp. */
1467 filter_read(int idx, SV *buf_sv, int maxlen)
1470 /* 0 = read one text line */
1475 if (!PL_rsfp_filters)
1477 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1478 /* Provide a default input filter to make life easy. */
1479 /* Note that we append to the line. This is handy. */
1481 warn("filter_read %d: from rsfp\n", idx);
1485 int old_len = SvCUR(buf_sv) ;
1487 /* ensure buf_sv is large enough */
1488 SvGROW(buf_sv, old_len + maxlen) ;
1489 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1490 if (PerlIO_error(PL_rsfp))
1491 return -1; /* error */
1493 return 0 ; /* end of file */
1495 SvCUR_set(buf_sv, old_len + len) ;
1498 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1499 if (PerlIO_error(PL_rsfp))
1500 return -1; /* error */
1502 return 0 ; /* end of file */
1505 return SvCUR(buf_sv);
1507 /* Skip this filter slot if filter has been deleted */
1508 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1510 warn("filter_read %d: skipped (filter deleted)\n", idx);
1511 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1513 /* Get function pointer hidden within datasv */
1514 funcp = (filter_t)IoDIRP(datasv);
1516 warn("filter_read %d: via function %p (%s)\n",
1517 idx, funcp, SvPV(datasv,PL_na));
1518 /* Call function. The function is expected to */
1519 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1520 /* Return: <0:error, =0:eof, >0:not eof */
1521 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1525 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1528 if (!PL_rsfp_filters) {
1529 filter_add(win32_textfilter,NULL);
1532 if (PL_rsfp_filters) {
1535 SvCUR_set(sv, 0); /* start with empty line */
1536 if (FILTER_READ(0, sv, 0) > 0)
1537 return ( SvPVX(sv) ) ;
1542 return (sv_gets(sv, fp, append));
1547 static char* exp_name[] =
1548 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1554 Works out what to call the token just pulled out of the input
1555 stream. The yacc parser takes care of taking the ops we return and
1556 stitching them into a tree.
1562 if read an identifier
1563 if we're in a my declaration
1564 croak if they tried to say my($foo::bar)
1565 build the ops for a my() declaration
1566 if it's an access to a my() variable
1567 are we in a sort block?
1568 croak if my($a); $a <=> $b
1569 build ops for access to a my() variable
1570 if in a dq string, and they've said @foo and we can't find @foo
1572 build ops for a bareword
1573 if we already built the token before, use it.
1577 #ifdef USE_PURE_BISON
1578 (YYSTYPE* lvalp, int* lcharp)
1591 #ifdef USE_PURE_BISON
1592 yylval_pointer = lvalp;
1593 yychar_pointer = lcharp;
1596 /* check if there's an identifier for us to look at */
1597 if (PL_pending_ident) {
1598 /* pit holds the identifier we read and pending_ident is reset */
1599 char pit = PL_pending_ident;
1600 PL_pending_ident = 0;
1602 /* if we're in a my(), we can't allow dynamics here.
1603 $foo'bar has already been turned into $foo::bar, so
1604 just check for colons.
1606 if it's a legal name, the OP is a PADANY.
1609 if (strchr(PL_tokenbuf,':'))
1610 croak(no_myglob,PL_tokenbuf);
1612 yylval.opval = newOP(OP_PADANY, 0);
1613 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1618 build the ops for accesses to a my() variable.
1620 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1621 then used in a comparison. This catches most, but not
1622 all cases. For instance, it catches
1623 sort { my($a); $a <=> $b }
1625 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1626 (although why you'd do that is anyone's guess).
1629 if (!strchr(PL_tokenbuf,':')) {
1631 /* Check for single character per-thread SVs */
1632 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1633 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1634 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1636 yylval.opval = newOP(OP_THREADSV, 0);
1637 yylval.opval->op_targ = tmp;
1640 #endif /* USE_THREADS */
1641 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1642 /* if it's a sort block and they're naming $a or $b */
1643 if (PL_last_lop_op == OP_SORT &&
1644 PL_tokenbuf[0] == '$' &&
1645 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1648 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1649 d < PL_bufend && *d != '\n';
1652 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1653 croak("Can't use \"my %s\" in sort comparison",
1659 yylval.opval = newOP(OP_PADANY, 0);
1660 yylval.opval->op_targ = tmp;
1666 Whine if they've said @foo in a doublequoted string,
1667 and @foo isn't a variable we can find in the symbol
1670 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1671 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1672 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1673 yyerror(form("In string, %s now must be written as \\%s",
1674 PL_tokenbuf, PL_tokenbuf));
1677 /* build ops for a bareword */
1678 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1679 yylval.opval->op_private = OPpCONST_ENTERED;
1680 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1681 ((PL_tokenbuf[0] == '$') ? SVt_PV
1682 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1687 /* no identifier pending identification */
1689 switch (PL_lex_state) {
1691 case LEX_NORMAL: /* Some compilers will produce faster */
1692 case LEX_INTERPNORMAL: /* code if we comment these out. */
1696 /* when we're already built the next token, just pull it out the queue */
1699 yylval = PL_nextval[PL_nexttoke];
1701 PL_lex_state = PL_lex_defer;
1702 PL_expect = PL_lex_expect;
1703 PL_lex_defer = LEX_NORMAL;
1705 return(PL_nexttype[PL_nexttoke]);
1707 /* interpolated case modifiers like \L \U, including \Q and \E.
1708 when we get here, PL_bufptr is at the \
1710 case LEX_INTERPCASEMOD:
1712 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1713 croak("panic: INTERPCASEMOD");
1715 /* handle \E or end of string */
1716 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1720 if (PL_lex_casemods) {
1721 oldmod = PL_lex_casestack[--PL_lex_casemods];
1722 PL_lex_casestack[PL_lex_casemods] = '\0';
1724 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1726 PL_lex_state = LEX_INTERPCONCAT;
1730 if (PL_bufptr != PL_bufend)
1732 PL_lex_state = LEX_INTERPCONCAT;
1733 return yylex(YYLEXPARAM);
1737 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1738 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1739 if (strchr("LU", *s) &&
1740 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1742 PL_lex_casestack[--PL_lex_casemods] = '\0';
1745 if (PL_lex_casemods > 10) {
1746 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1747 if (newlb != PL_lex_casestack) {
1749 PL_lex_casestack = newlb;
1752 PL_lex_casestack[PL_lex_casemods++] = *s;
1753 PL_lex_casestack[PL_lex_casemods] = '\0';
1754 PL_lex_state = LEX_INTERPCONCAT;
1755 PL_nextval[PL_nexttoke].ival = 0;
1758 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1760 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1762 PL_nextval[PL_nexttoke].ival = OP_LC;
1764 PL_nextval[PL_nexttoke].ival = OP_UC;
1766 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1768 croak("panic: yylex");
1771 if (PL_lex_starts) {
1777 return yylex(YYLEXPARAM);
1780 case LEX_INTERPPUSH:
1781 return sublex_push();
1783 case LEX_INTERPSTART:
1784 if (PL_bufptr == PL_bufend)
1785 return sublex_done();
1787 PL_lex_dojoin = (*PL_bufptr == '@');
1788 PL_lex_state = LEX_INTERPNORMAL;
1789 if (PL_lex_dojoin) {
1790 PL_nextval[PL_nexttoke].ival = 0;
1793 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1794 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1795 force_next(PRIVATEREF);
1797 force_ident("\"", '$');
1798 #endif /* USE_THREADS */
1799 PL_nextval[PL_nexttoke].ival = 0;
1801 PL_nextval[PL_nexttoke].ival = 0;
1803 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1806 if (PL_lex_starts++) {
1810 return yylex(YYLEXPARAM);
1812 case LEX_INTERPENDMAYBE:
1813 if (intuit_more(PL_bufptr)) {
1814 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1820 if (PL_lex_dojoin) {
1821 PL_lex_dojoin = FALSE;
1822 PL_lex_state = LEX_INTERPCONCAT;
1826 case LEX_INTERPCONCAT:
1828 if (PL_lex_brackets)
1829 croak("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++)
1859 return yylex(YYLEXPARAM);
1863 return yylex(YYLEXPARAM);
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);
1883 * Note: we try to be careful never to call the isXXX_utf8() functions unless we're
1884 * pretty sure we've seen the beginning of a UTF-8 character (that is, the two high
1885 * bits are set). Otherwise we risk loading in the heavy-duty SWASHINIT and SWASHGET
1886 * routines unnecessarily. You will see this not just here but throughout this file.
1888 if (UTF && (*s & 0xc0) == 0x80) {
1889 if (isIDFIRST_utf8((U8*)s))
1892 croak("Unrecognized character \\x%02X", *s & 255);
1895 goto fake_eof; /* emulate EOF on ^D or ^Z */
1900 if (PL_lex_brackets)
1901 yyerror("Missing right bracket");
1904 if (s++ < PL_bufend)
1905 goto retry; /* ignore stray nulls */
1908 if (!PL_in_eval && !PL_preambled) {
1909 PL_preambled = TRUE;
1910 sv_setpv(PL_linestr,incl_perldb());
1911 if (SvCUR(PL_linestr))
1912 sv_catpv(PL_linestr,";");
1914 while(AvFILLp(PL_preambleav) >= 0) {
1915 SV *tmpsv = av_shift(PL_preambleav);
1916 sv_catsv(PL_linestr, tmpsv);
1917 sv_catpv(PL_linestr, ";");
1920 sv_free((SV*)PL_preambleav);
1921 PL_preambleav = NULL;
1923 if (PL_minus_n || PL_minus_p) {
1924 sv_catpv(PL_linestr, "LINE: while (<>) {");
1926 sv_catpv(PL_linestr,"chomp;");
1928 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1930 GvIMPORTED_AV_on(gv);
1932 if (strchr("/'\"", *PL_splitstr)
1933 && strchr(PL_splitstr + 1, *PL_splitstr))
1934 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1937 s = "'~#\200\1'"; /* surely one char is unused...*/
1938 while (s[1] && strchr(PL_splitstr, *s)) s++;
1940 sv_catpvf(PL_linestr, "@F=split(%s%c",
1941 "q" + (delim == '\''), delim);
1942 for (s = PL_splitstr; *s; s++) {
1944 sv_catpvn(PL_linestr, "\\", 1);
1945 sv_catpvn(PL_linestr, s, 1);
1947 sv_catpvf(PL_linestr, "%c);", delim);
1951 sv_catpv(PL_linestr,"@F=split(' ');");
1954 sv_catpv(PL_linestr, "\n");
1955 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1956 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1957 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1958 SV *sv = NEWSV(85,0);
1960 sv_upgrade(sv, SVt_PVMG);
1961 sv_setsv(sv,PL_linestr);
1962 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1967 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1970 if (PL_preprocess && !PL_in_eval)
1971 (void)PerlProc_pclose(PL_rsfp);
1972 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1973 PerlIO_clearerr(PL_rsfp);
1975 (void)PerlIO_close(PL_rsfp);
1977 PL_doextract = FALSE;
1979 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1980 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1981 sv_catpv(PL_linestr,";}");
1982 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1983 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1984 PL_minus_n = PL_minus_p = 0;
1987 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1988 sv_setpv(PL_linestr,"");
1989 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1992 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1993 PL_doextract = FALSE;
1995 /* Incest with pod. */
1996 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1997 sv_setpv(PL_linestr, "");
1998 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1999 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2000 PL_doextract = FALSE;
2004 } while (PL_doextract);
2005 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2006 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2007 SV *sv = NEWSV(85,0);
2009 sv_upgrade(sv, SVt_PVMG);
2010 sv_setsv(sv,PL_linestr);
2011 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2013 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2014 if (PL_curcop->cop_line == 1) {
2015 while (s < PL_bufend && isSPACE(*s))
2017 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2021 if (*s == '#' && *(s+1) == '!')
2023 #ifdef ALTERNATE_SHEBANG
2025 static char as[] = ALTERNATE_SHEBANG;
2026 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2027 d = s + (sizeof(as) - 1);
2029 #endif /* ALTERNATE_SHEBANG */
2038 while (*d && !isSPACE(*d))
2042 #ifdef ARG_ZERO_IS_SCRIPT
2043 if (ipathend > ipath) {
2045 * HP-UX (at least) sets argv[0] to the script name,
2046 * which makes $^X incorrect. And Digital UNIX and Linux,
2047 * at least, set argv[0] to the basename of the Perl
2048 * interpreter. So, having found "#!", we'll set it right.
2050 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2051 assert(SvPOK(x) || SvGMAGICAL(x));
2052 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2053 sv_setpvn(x, ipath, ipathend - ipath);
2056 TAINT_NOT; /* $^X is always tainted, but that's OK */
2058 #endif /* ARG_ZERO_IS_SCRIPT */
2063 d = instr(s,"perl -");
2065 d = instr(s,"perl");
2066 #ifdef ALTERNATE_SHEBANG
2068 * If the ALTERNATE_SHEBANG on this system starts with a
2069 * character that can be part of a Perl expression, then if
2070 * we see it but not "perl", we're probably looking at the
2071 * start of Perl code, not a request to hand off to some
2072 * other interpreter. Similarly, if "perl" is there, but
2073 * not in the first 'word' of the line, we assume the line
2074 * contains the start of the Perl program.
2076 if (d && *s != '#') {
2078 while (*c && !strchr("; \t\r\n\f\v#", *c))
2081 d = Nullch; /* "perl" not in first word; ignore */
2083 *s = '#'; /* Don't try to parse shebang line */
2085 #endif /* ALTERNATE_SHEBANG */
2090 !instr(s,"indir") &&
2091 instr(PL_origargv[0],"perl"))
2097 while (s < PL_bufend && isSPACE(*s))
2099 if (s < PL_bufend) {
2100 Newz(899,newargv,PL_origargc+3,char*);
2102 while (s < PL_bufend && !isSPACE(*s))
2105 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2108 newargv = PL_origargv;
2110 execv(ipath, newargv);
2111 croak("Can't exec %s", ipath);
2114 U32 oldpdb = PL_perldb;
2115 bool oldn = PL_minus_n;
2116 bool oldp = PL_minus_p;
2118 while (*d && !isSPACE(*d)) d++;
2119 while (*d == ' ' || *d == '\t') d++;
2123 if (*d == 'M' || *d == 'm') {
2125 while (*d && !isSPACE(*d)) d++;
2126 croak("Too late for \"-%.*s\" option",
2129 d = moreswitches(d);
2131 if (PERLDB_LINE && !oldpdb ||
2132 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2133 /* if we have already added "LINE: while (<>) {",
2134 we must not do it again */
2136 sv_setpv(PL_linestr, "");
2137 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2138 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2139 PL_preambled = FALSE;
2141 (void)gv_fetchfile(PL_origfilename);
2148 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2150 PL_lex_state = LEX_FORMLINE;
2151 return yylex(YYLEXPARAM);
2155 #ifdef PERL_STRICT_CR
2156 warn("Illegal character \\%03o (carriage return)", '\r');
2158 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2160 case ' ': case '\t': case '\f': case 013:
2165 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2167 while (s < d && *s != '\n')
2172 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2174 PL_lex_state = LEX_FORMLINE;
2175 return yylex(YYLEXPARAM);
2184 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2189 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2192 if (strnEQ(s,"=>",2)) {
2193 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2194 OPERATOR('-'); /* unary minus */
2196 PL_last_uni = PL_oldbufptr;
2197 PL_last_lop_op = OP_FTEREAD; /* good enough */
2199 case 'r': FTST(OP_FTEREAD);
2200 case 'w': FTST(OP_FTEWRITE);
2201 case 'x': FTST(OP_FTEEXEC);
2202 case 'o': FTST(OP_FTEOWNED);
2203 case 'R': FTST(OP_FTRREAD);
2204 case 'W': FTST(OP_FTRWRITE);
2205 case 'X': FTST(OP_FTREXEC);
2206 case 'O': FTST(OP_FTROWNED);
2207 case 'e': FTST(OP_FTIS);
2208 case 'z': FTST(OP_FTZERO);
2209 case 's': FTST(OP_FTSIZE);
2210 case 'f': FTST(OP_FTFILE);
2211 case 'd': FTST(OP_FTDIR);
2212 case 'l': FTST(OP_FTLINK);
2213 case 'p': FTST(OP_FTPIPE);
2214 case 'S': FTST(OP_FTSOCK);
2215 case 'u': FTST(OP_FTSUID);
2216 case 'g': FTST(OP_FTSGID);
2217 case 'k': FTST(OP_FTSVTX);
2218 case 'b': FTST(OP_FTBLK);
2219 case 'c': FTST(OP_FTCHR);
2220 case 't': FTST(OP_FTTTY);
2221 case 'T': FTST(OP_FTTEXT);
2222 case 'B': FTST(OP_FTBINARY);
2223 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2224 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2225 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2227 croak("Unrecognized file test: -%c", (int)tmp);
2234 if (PL_expect == XOPERATOR)
2239 else if (*s == '>') {
2242 if (isIDFIRST(*s)) {
2243 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2251 if (PL_expect == XOPERATOR)
2254 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2256 OPERATOR('-'); /* unary minus */
2263 if (PL_expect == XOPERATOR)
2268 if (PL_expect == XOPERATOR)
2271 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2277 if (PL_expect != XOPERATOR) {
2278 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2279 PL_expect = XOPERATOR;
2280 force_ident(PL_tokenbuf, '*');
2293 if (PL_expect == XOPERATOR) {
2297 PL_tokenbuf[0] = '%';
2298 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2299 if (!PL_tokenbuf[1]) {
2301 yyerror("Final % should be \\% or %name");
2304 PL_pending_ident = '%';
2326 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2327 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2332 if (PL_curcop->cop_line < PL_copline)
2333 PL_copline = PL_curcop->cop_line;
2344 if (PL_lex_brackets <= 0)
2345 yyerror("Unmatched right bracket");
2348 if (PL_lex_state == LEX_INTERPNORMAL) {
2349 if (PL_lex_brackets == 0) {
2350 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2351 PL_lex_state = LEX_INTERPEND;
2358 if (PL_lex_brackets > 100) {
2359 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2360 if (newlb != PL_lex_brackstack) {
2362 PL_lex_brackstack = newlb;
2365 switch (PL_expect) {
2367 if (PL_lex_formbrack) {
2371 if (PL_oldoldbufptr == PL_last_lop)
2372 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2374 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2375 OPERATOR(HASHBRACK);
2377 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2380 PL_tokenbuf[0] = '\0';
2381 if (d < PL_bufend && *d == '-') {
2382 PL_tokenbuf[0] = '-';
2384 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2387 if (d < PL_bufend && isIDFIRST(*d)) {
2388 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2390 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2393 char minus = (PL_tokenbuf[0] == '-');
2394 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2401 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2405 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2410 if (PL_oldoldbufptr == PL_last_lop)
2411 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2413 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2416 OPERATOR(HASHBRACK);
2417 /* This hack serves to disambiguate a pair of curlies
2418 * as being a block or an anon hash. Normally, expectation
2419 * determines that, but in cases where we're not in a
2420 * position to expect anything in particular (like inside
2421 * eval"") we have to resolve the ambiguity. This code
2422 * covers the case where the first term in the curlies is a
2423 * quoted string. Most other cases need to be explicitly
2424 * disambiguated by prepending a `+' before the opening
2425 * curly in order to force resolution as an anon hash.
2427 * XXX should probably propagate the outer expectation
2428 * into eval"" to rely less on this hack, but that could
2429 * potentially break current behavior of eval"".
2433 if (*s == '\'' || *s == '"' || *s == '`') {
2434 /* common case: get past first string, handling escapes */
2435 for (t++; t < PL_bufend && *t != *s;)
2436 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2440 else if (*s == 'q') {
2443 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2444 && !isALNUM(*t)))) {
2446 char open, close, term;
2449 while (t < PL_bufend && isSPACE(*t))
2453 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2457 for (t++; t < PL_bufend; t++) {
2458 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2460 else if (*t == open)
2464 for (t++; t < PL_bufend; t++) {
2465 if (*t == '\\' && t+1 < PL_bufend)
2467 else if (*t == close && --brackets <= 0)
2469 else if (*t == open)
2475 else if (isALPHA(*s)) {
2476 for (t++; t < PL_bufend && isALNUM(*t); t++) ;
2478 while (t < PL_bufend && isSPACE(*t))
2480 /* if comma follows first term, call it an anon hash */
2481 /* XXX it could be a comma expression with loop modifiers */
2482 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2483 || (*t == '=' && t[1] == '>')))
2484 OPERATOR(HASHBRACK);
2485 if (PL_expect == XREF)
2488 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2494 yylval.ival = PL_curcop->cop_line;
2495 if (isSPACE(*s) || *s == '#')
2496 PL_copline = NOLINE; /* invalidate current command line number */
2501 if (PL_lex_brackets <= 0)
2502 yyerror("Unmatched right bracket");
2504 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2505 if (PL_lex_brackets < PL_lex_formbrack)
2506 PL_lex_formbrack = 0;
2507 if (PL_lex_state == LEX_INTERPNORMAL) {
2508 if (PL_lex_brackets == 0) {
2509 if (PL_lex_fakebrack) {
2510 PL_lex_state = LEX_INTERPEND;
2512 return yylex(YYLEXPARAM); /* ignore fake brackets */
2514 if (*s == '-' && s[1] == '>')
2515 PL_lex_state = LEX_INTERPENDMAYBE;
2516 else if (*s != '[' && *s != '{')
2517 PL_lex_state = LEX_INTERPEND;
2520 if (PL_lex_brackets < PL_lex_fakebrack) {
2522 PL_lex_fakebrack = 0;
2523 return yylex(YYLEXPARAM); /* ignore fake brackets */
2533 if (PL_expect == XOPERATOR) {
2534 if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && PL_bufptr == PL_linestart) {
2535 PL_curcop->cop_line--;
2536 warner(WARN_SEMICOLON, warn_nosemi);
2537 PL_curcop->cop_line++;
2542 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2544 PL_expect = XOPERATOR;
2545 force_ident(PL_tokenbuf, '&');
2549 yylval.ival = (OPpENTERSUB_AMPER<<8);
2568 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2569 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2571 if (PL_expect == XSTATE && isALPHA(tmp) &&
2572 (s == PL_linestart+1 || s[-2] == '\n') )
2574 if (PL_in_eval && !PL_rsfp) {
2579 if (strnEQ(s,"=cut",4)) {
2593 PL_doextract = TRUE;
2596 if (PL_lex_brackets < PL_lex_formbrack) {
2598 #ifdef PERL_STRICT_CR
2599 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2601 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2603 if (*t == '\n' || *t == '#') {
2621 if (PL_expect != XOPERATOR) {
2622 if (s[1] != '<' && !strchr(s,'>'))
2625 s = scan_heredoc(s);
2627 s = scan_inputsymbol(s);
2628 TERM(sublex_start());
2633 SHop(OP_LEFT_SHIFT);
2647 SHop(OP_RIGHT_SHIFT);
2656 if (PL_expect == XOPERATOR) {
2657 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2660 return ','; /* grandfather non-comma-format format */
2664 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:+-", s[2]))) {
2665 if (PL_expect == XOPERATOR)
2666 no_op("Array length", PL_bufptr);
2667 PL_tokenbuf[0] = '@';
2668 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2670 if (!PL_tokenbuf[1])
2672 PL_expect = XOPERATOR;
2673 PL_pending_ident = '#';
2677 if (PL_expect == XOPERATOR)
2678 no_op("Scalar", PL_bufptr);
2679 PL_tokenbuf[0] = '$';
2680 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2681 if (!PL_tokenbuf[1]) {
2683 yyerror("Final $ should be \\$ or $name");
2687 /* This kludge not intended to be bulletproof. */
2688 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2689 yylval.opval = newSVOP(OP_CONST, 0,
2690 newSViv((IV)PL_compiling.cop_arybase));
2691 yylval.opval->op_private = OPpCONST_ARYBASE;
2696 if (PL_lex_state == LEX_NORMAL)
2699 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2702 PL_tokenbuf[0] = '@';
2703 if (ckWARN(WARN_SYNTAX)) {
2705 isSPACE(*t) || isALNUM(*t) || *t == '$';
2708 PL_bufptr = skipspace(PL_bufptr);
2709 while (t < PL_bufend && *t != ']')
2712 "Multidimensional syntax %.*s not supported",
2713 (t - PL_bufptr) + 1, PL_bufptr);
2717 else if (*s == '{') {
2718 PL_tokenbuf[0] = '%';
2719 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2720 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2722 char tmpbuf[sizeof PL_tokenbuf];
2724 for (t++; isSPACE(*t); t++) ;
2725 if (isIDFIRST(*t)) {
2726 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2727 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2729 "You need to quote \"%s\"", tmpbuf);
2735 PL_expect = XOPERATOR;
2736 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2737 bool islop = (PL_last_lop == PL_oldoldbufptr);
2738 if (!islop || PL_last_lop_op == OP_GREPSTART)
2739 PL_expect = XOPERATOR;
2740 else if (strchr("$@\"'`q", *s))
2741 PL_expect = XTERM; /* e.g. print $fh "foo" */
2742 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2743 PL_expect = XTERM; /* e.g. print $fh &sub */
2744 else if (isIDFIRST(*s)) {
2745 char tmpbuf[sizeof PL_tokenbuf];
2746 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2747 if (tmp = keyword(tmpbuf, len)) {
2748 /* binary operators exclude handle interpretations */
2760 PL_expect = XTERM; /* e.g. print $fh length() */
2765 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2766 if (gv && GvCVu(gv))
2767 PL_expect = XTERM; /* e.g. print $fh subr() */
2770 else if (isDIGIT(*s))
2771 PL_expect = XTERM; /* e.g. print $fh 3 */
2772 else if (*s == '.' && isDIGIT(s[1]))
2773 PL_expect = XTERM; /* e.g. print $fh .3 */
2774 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2775 PL_expect = XTERM; /* e.g. print $fh -1 */
2776 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2777 PL_expect = XTERM; /* print $fh <<"EOF" */
2779 PL_pending_ident = '$';
2783 if (PL_expect == XOPERATOR)
2785 PL_tokenbuf[0] = '@';
2786 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2787 if (!PL_tokenbuf[1]) {
2789 yyerror("Final @ should be \\@ or @name");
2792 if (PL_lex_state == LEX_NORMAL)
2794 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2796 PL_tokenbuf[0] = '%';
2798 /* Warn about @ where they meant $. */
2799 if (ckWARN(WARN_SYNTAX)) {
2800 if (*s == '[' || *s == '{') {
2802 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2804 if (*t == '}' || *t == ']') {
2806 PL_bufptr = skipspace(PL_bufptr);
2808 "Scalar value %.*s better written as $%.*s",
2809 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2814 PL_pending_ident = '@';
2817 case '/': /* may either be division or pattern */
2818 case '?': /* may either be conditional or pattern */
2819 if (PL_expect != XOPERATOR) {
2820 /* Disable warning on "study /blah/" */
2821 if (PL_oldoldbufptr == PL_last_uni
2822 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2823 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2825 s = scan_pat(s,OP_MATCH);
2826 TERM(sublex_start());
2834 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2835 #ifdef PERL_STRICT_CR
2838 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2840 && (s == PL_linestart || s[-1] == '\n') )
2842 PL_lex_formbrack = 0;
2846 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2852 yylval.ival = OPf_SPECIAL;
2858 if (PL_expect != XOPERATOR)
2863 case '0': case '1': case '2': case '3': case '4':
2864 case '5': case '6': case '7': case '8': case '9':
2866 if (PL_expect == XOPERATOR)
2872 if (PL_expect == XOPERATOR) {
2873 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2876 return ','; /* grandfather non-comma-format format */
2882 missingterm((char*)0);
2883 yylval.ival = OP_CONST;
2884 TERM(sublex_start());
2888 if (PL_expect == XOPERATOR) {
2889 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2892 return ','; /* grandfather non-comma-format format */
2898 missingterm((char*)0);
2899 yylval.ival = OP_CONST;
2900 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2901 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2902 yylval.ival = OP_STRINGIFY;
2906 TERM(sublex_start());
2910 if (PL_expect == XOPERATOR)
2911 no_op("Backticks",s);
2913 missingterm((char*)0);
2914 yylval.ival = OP_BACKTICK;
2916 TERM(sublex_start());
2920 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2921 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2923 if (PL_expect == XOPERATOR)
2924 no_op("Backslash",s);
2928 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2967 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2969 /* Some keywords can be followed by any delimiter, including ':' */
2970 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2971 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2972 (PL_tokenbuf[0] == 'q' &&
2973 strchr("qwxr", PL_tokenbuf[1]))));
2975 /* x::* is just a word, unless x is "CORE" */
2976 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2980 while (d < PL_bufend && isSPACE(*d))
2981 d++; /* no comments skipped here, or s### is misparsed */
2983 /* Is this a label? */
2984 if (!tmp && PL_expect == XSTATE
2985 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2987 yylval.pval = savepv(PL_tokenbuf);
2992 /* Check for keywords */
2993 tmp = keyword(PL_tokenbuf, len);
2995 /* Is this a word before a => operator? */
2996 if (strnEQ(d,"=>",2)) {
2998 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2999 yylval.opval->op_private = OPpCONST_BARE;
3003 if (tmp < 0) { /* second-class keyword? */
3004 GV *ogv = Nullgv; /* override (winner) */
3005 GV *hgv = Nullgv; /* hidden (loser) */
3006 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3008 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3011 if (GvIMPORTED_CV(gv))
3013 else if (! CvMETHOD(cv))
3017 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3018 (gv = *gvp) != (GV*)&PL_sv_undef &&
3019 GvCVu(gv) && GvIMPORTED_CV(gv))
3025 tmp = 0; /* overridden by import or by GLOBAL */
3028 && -tmp==KEY_lock /* XXX generalizable kludge */
3029 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3031 tmp = 0; /* any sub overrides "weak" keyword */
3033 else { /* no override */
3037 if (ckWARN(WARN_AMBIGUOUS) && hgv
3038 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3039 warner(WARN_AMBIGUOUS,
3040 "Ambiguous call resolved as CORE::%s(), %s",
3041 GvENAME(hgv), "qualify as such or use &");
3048 default: /* not a keyword */
3051 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3053 /* Get the rest if it looks like a package qualifier */
3055 if (*s == '\'' || *s == ':' && s[1] == ':') {
3057 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3060 croak("Bad name after %s%s", PL_tokenbuf,
3061 *s == '\'' ? "'" : "::");
3065 if (PL_expect == XOPERATOR) {
3066 if (PL_bufptr == PL_linestart) {
3067 PL_curcop->cop_line--;
3068 warner(WARN_SEMICOLON, warn_nosemi);
3069 PL_curcop->cop_line++;
3072 no_op("Bareword",s);
3075 /* Look for a subroutine with this name in current package,
3076 unless name is "Foo::", in which case Foo is a bearword
3077 (and a package name). */
3080 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3082 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3084 "Bareword \"%s\" refers to nonexistent package",
3087 PL_tokenbuf[len] = '\0';
3094 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3097 /* if we saw a global override before, get the right name */
3100 sv = newSVpv("CORE::GLOBAL::",14);
3101 sv_catpv(sv,PL_tokenbuf);
3104 sv = newSVpv(PL_tokenbuf,0);
3106 /* Presume this is going to be a bareword of some sort. */
3109 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3110 yylval.opval->op_private = OPpCONST_BARE;
3112 /* And if "Foo::", then that's what it certainly is. */
3117 /* See if it's the indirect object for a list operator. */
3119 if (PL_oldoldbufptr &&
3120 PL_oldoldbufptr < PL_bufptr &&
3121 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3122 /* NO SKIPSPACE BEFORE HERE! */
3124 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3125 || (PL_last_lop_op == OP_ENTERSUB
3127 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3129 bool immediate_paren = *s == '(';
3131 /* (Now we can afford to cross potential line boundary.) */
3134 /* Two barewords in a row may indicate method call. */
3136 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
3139 /* If not a declared subroutine, it's an indirect object. */
3140 /* (But it's an indir obj regardless for sort.) */
3142 if ((PL_last_lop_op == OP_SORT ||
3143 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3144 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3145 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3150 /* If followed by a paren, it's certainly a subroutine. */
3152 PL_expect = XOPERATOR;
3156 if (gv && GvCVu(gv)) {
3157 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3158 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3163 PL_nextval[PL_nexttoke].opval = yylval.opval;
3164 PL_expect = XOPERATOR;
3170 /* If followed by var or block, call it a method (unless sub) */
3172 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3173 PL_last_lop = PL_oldbufptr;
3174 PL_last_lop_op = OP_METHOD;
3178 /* If followed by a bareword, see if it looks like indir obj. */
3180 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3183 /* Not a method, so call it a subroutine (if defined) */
3185 if (gv && GvCVu(gv)) {
3187 if (lastchar == '-')
3188 warn("Ambiguous use of -%s resolved as -&%s()",
3189 PL_tokenbuf, PL_tokenbuf);
3190 PL_last_lop = PL_oldbufptr;
3191 PL_last_lop_op = OP_ENTERSUB;
3192 /* Check for a constant sub */
3194 if ((sv = cv_const_sv(cv))) {
3196 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3197 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3198 yylval.opval->op_private = 0;
3202 /* Resolve to GV now. */
3203 op_free(yylval.opval);
3204 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3205 /* Is there a prototype? */
3208 PL_last_proto = SvPV((SV*)cv, len);
3211 if (strEQ(PL_last_proto, "$"))
3213 if (*PL_last_proto == '&' && *s == '{') {
3214 sv_setpv(PL_subname,"__ANON__");
3218 PL_last_proto = NULL;
3219 PL_nextval[PL_nexttoke].opval = yylval.opval;
3225 if (PL_hints & HINT_STRICT_SUBS &&
3228 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3229 PL_last_lop_op != OP_ACCEPT &&
3230 PL_last_lop_op != OP_PIPE_OP &&
3231 PL_last_lop_op != OP_SOCKPAIR)
3234 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3239 /* Call it a bare word */
3242 if (ckWARN(WARN_RESERVED)) {
3243 if (lastchar != '-') {
3244 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3246 warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
3251 if (lastchar && strchr("*%&", lastchar)) {
3252 warn("Operator or semicolon missing before %c%s",
3253 lastchar, PL_tokenbuf);
3254 warn("Ambiguous use of %c resolved as operator %c",
3255 lastchar, lastchar);
3261 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3262 newSVsv(GvSV(PL_curcop->cop_filegv)));
3266 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3267 newSVpvf("%ld", (long)PL_curcop->cop_line));
3270 case KEY___PACKAGE__:
3271 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3273 ? newSVsv(PL_curstname)
3282 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3283 char *pname = "main";
3284 if (PL_tokenbuf[2] == 'D')
3285 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3286 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3289 GvIOp(gv) = newIO();
3290 IoIFP(GvIOp(gv)) = PL_rsfp;
3291 #if defined(HAS_FCNTL) && defined(F_SETFD)
3293 int fd = PerlIO_fileno(PL_rsfp);
3294 fcntl(fd,F_SETFD,fd >= 3);
3297 /* Mark this internal pseudo-handle as clean */
3298 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3300 IoTYPE(GvIOp(gv)) = '|';
3301 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3302 IoTYPE(GvIOp(gv)) = '-';
3304 IoTYPE(GvIOp(gv)) = '<';
3315 if (PL_expect == XSTATE) {
3322 if (*s == ':' && s[1] == ':') {
3325 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3326 tmp = keyword(PL_tokenbuf, len);
3340 LOP(OP_ACCEPT,XTERM);
3346 LOP(OP_ATAN2,XTERM);
3355 LOP(OP_BLESS,XTERM);
3364 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3381 if (!PL_cryptseen++)
3384 LOP(OP_CRYPT,XTERM);
3387 if (ckWARN(WARN_OCTAL)) {
3388 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3389 if (*d != '0' && isDIGIT(*d))
3390 yywarn("chmod: mode argument is missing initial 0");
3392 LOP(OP_CHMOD,XTERM);
3395 LOP(OP_CHOWN,XTERM);
3398 LOP(OP_CONNECT,XTERM);
3414 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3418 PL_hints |= HINT_BLOCK_SCOPE;
3428 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3429 LOP(OP_DBMOPEN,XTERM);
3435 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3442 yylval.ival = PL_curcop->cop_line;
3456 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3457 UNIBRACK(OP_ENTEREVAL);
3472 case KEY_endhostent:
3478 case KEY_endservent:
3481 case KEY_endprotoent:
3492 yylval.ival = PL_curcop->cop_line;
3494 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3496 if ((PL_bufend - p) >= 3 &&
3497 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3501 croak("Missing $ on loop variable");
3506 LOP(OP_FORMLINE,XTERM);
3512 LOP(OP_FCNTL,XTERM);
3518 LOP(OP_FLOCK,XTERM);
3527 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3530 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3545 case KEY_getpriority:
3546 LOP(OP_GETPRIORITY,XTERM);
3548 case KEY_getprotobyname:
3551 case KEY_getprotobynumber:
3552 LOP(OP_GPBYNUMBER,XTERM);
3554 case KEY_getprotoent:
3566 case KEY_getpeername:
3567 UNI(OP_GETPEERNAME);
3569 case KEY_gethostbyname:
3572 case KEY_gethostbyaddr:
3573 LOP(OP_GHBYADDR,XTERM);
3575 case KEY_gethostent:
3578 case KEY_getnetbyname:
3581 case KEY_getnetbyaddr:
3582 LOP(OP_GNBYADDR,XTERM);
3587 case KEY_getservbyname:
3588 LOP(OP_GSBYNAME,XTERM);
3590 case KEY_getservbyport:
3591 LOP(OP_GSBYPORT,XTERM);
3593 case KEY_getservent:
3596 case KEY_getsockname:
3597 UNI(OP_GETSOCKNAME);
3599 case KEY_getsockopt:
3600 LOP(OP_GSOCKOPT,XTERM);
3622 yylval.ival = PL_curcop->cop_line;
3626 LOP(OP_INDEX,XTERM);
3632 LOP(OP_IOCTL,XTERM);
3644 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3675 LOP(OP_LISTEN,XTERM);
3684 s = scan_pat(s,OP_MATCH);
3685 TERM(sublex_start());
3688 LOP(OP_MAPSTART,XREF);
3691 LOP(OP_MKDIR,XTERM);
3694 LOP(OP_MSGCTL,XTERM);
3697 LOP(OP_MSGGET,XTERM);
3700 LOP(OP_MSGRCV,XTERM);
3703 LOP(OP_MSGSND,XTERM);
3708 if (isIDFIRST(*s)) {
3709 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3710 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3711 if (!PL_in_my_stash) {
3714 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3721 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3728 if (PL_expect != XSTATE)
3729 yyerror("\"no\" not allowed in expression");
3730 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3731 s = force_version(s);
3740 if (isIDFIRST(*s)) {
3742 for (d = s; isALNUM(*d); d++) ;
3744 if (strchr("|&*+-=!?:.", *t))
3745 warn("Precedence problem: open %.*s should be open(%.*s)",
3751 yylval.ival = OP_OR;
3761 LOP(OP_OPEN_DIR,XTERM);
3764 checkcomma(s,PL_tokenbuf,"filehandle");
3768 checkcomma(s,PL_tokenbuf,"filehandle");
3787 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3791 LOP(OP_PIPE_OP,XTERM);
3796 missingterm((char*)0);
3797 yylval.ival = OP_CONST;
3798 TERM(sublex_start());
3806 missingterm((char*)0);
3807 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3808 d = SvPV_force(PL_lex_stuff, len);
3809 for (; len; --len, ++d) {
3812 "Possible attempt to separate words with commas");
3817 "Possible attempt to put comments in qw() list");
3823 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3824 PL_lex_stuff = Nullsv;
3827 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3830 yylval.ival = OP_SPLIT;
3834 PL_last_lop = PL_oldbufptr;
3835 PL_last_lop_op = OP_SPLIT;
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(*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 croak("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(*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 croak("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,PL_na) == '?') {
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 keyword(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")) warn("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 checkcomma(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 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4915 while (s < PL_bufend && isSPACE(*s))
4919 while (s < PL_bufend && isSPACE(*s))
4921 if (isIDFIRST(*s)) {
4925 while (s < PL_bufend && isSPACE(*s))
4930 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4934 croak("No comma allowed after %s", what);
4940 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4943 HV *table = GvHV(PL_hintgv); /* ^H */
4946 bool oldcatch = CATCH_GET;
4952 yyerror("%^H is not defined");
4955 cvp = hv_fetch(table, key, strlen(key), FALSE);
4956 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(newSVpv(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;
4991 if (PL_op = pp_entersub(ARGS))
4998 CATCH_SET(oldcatch);
5002 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5005 return SvREFCNT_inc(res);
5009 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5011 register char *d = dest;
5012 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5015 croak(ident_too_long);
5018 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
5023 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5027 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
5028 char *t = s + UTF8SKIP(s);
5029 while (*t & 0x80 && is_utf8_mark((U8*)t))
5031 if (d + (t - s) > e)
5032 croak(ident_too_long);
5033 Copy(s, d, t - s, char);
5046 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5053 if (PL_lex_brackets == 0)
5054 PL_lex_fakebrack = 0;
5058 e = d + destlen - 3; /* two-character token, ending NUL */
5060 while (isDIGIT(*s)) {
5062 croak(ident_too_long);
5069 croak(ident_too_long);
5072 else if (*s == '\'' && isIDFIRST(s[1])) {
5077 else if (*s == ':' && s[1] == ':') {
5081 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
5082 char *t = s + UTF8SKIP(s);
5083 while (*t & 0x80 && is_utf8_mark((U8*)t))
5085 if (d + (t - s) > e)
5086 croak(ident_too_long);
5087 Copy(s, d, t - s, char);
5098 if (PL_lex_state != LEX_NORMAL)
5099 PL_lex_state = LEX_INTERPENDMAYBE;
5102 if (*s == '$' && s[1] &&
5103 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5116 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5121 if (isSPACE(s[-1])) {
5124 if (ch != ' ' && ch != '\t') {
5130 if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8((U8*)d))) {
5134 while (e < send && (isALNUM(*e) || ((*e & 0xc0) == 0x80 && isALNUM_utf8((U8*)e)) || *e == ':')) {
5136 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5139 Copy(s, d, e - s, char);
5144 while (isALNUM(*s) || *s == ':')
5148 while (s < send && (*s == ' ' || *s == '\t')) s++;
5149 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5150 dTHR; /* only for ckWARN */
5151 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5152 char *brack = *s == '[' ? "[...]" : "{...}";
5153 warner(WARN_AMBIGUOUS,
5154 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5155 funny, dest, brack, funny, dest, brack);
5157 PL_lex_fakebrack = PL_lex_brackets+1;
5159 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5165 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5166 PL_lex_state = LEX_INTERPEND;
5169 if (PL_lex_state == LEX_NORMAL) {
5170 dTHR; /* only for ckWARN */
5171 if (ckWARN(WARN_AMBIGUOUS) &&
5172 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5174 warner(WARN_AMBIGUOUS,
5175 "Ambiguous use of %c{%s} resolved to %c%s",
5176 funny, dest, funny, dest);
5181 s = bracket; /* let the parser handle it */
5185 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5186 PL_lex_state = LEX_INTERPEND;
5190 void pmflag(U16 *pmfl, int ch)
5195 *pmfl |= PMf_GLOBAL;
5197 *pmfl |= PMf_CONTINUE;
5201 *pmfl |= PMf_MULTILINE;
5203 *pmfl |= PMf_SINGLELINE;
5205 *pmfl |= PMf_EXTENDED;
5209 scan_pat(char *start, I32 type)
5214 s = scan_str(start);
5217 SvREFCNT_dec(PL_lex_stuff);
5218 PL_lex_stuff = Nullsv;
5219 croak("Search pattern not terminated");
5222 pm = (PMOP*)newPMOP(type, 0);
5223 if (PL_multi_open == '?')
5224 pm->op_pmflags |= PMf_ONCE;
5226 while (*s && strchr("iomsx", *s))
5227 pmflag(&pm->op_pmflags,*s++);
5230 while (*s && strchr("iogcmsx", *s))
5231 pmflag(&pm->op_pmflags,*s++);
5233 pm->op_pmpermflags = pm->op_pmflags;
5235 PL_lex_op = (OP*)pm;
5236 yylval.ival = OP_MATCH;
5241 scan_subst(char *start)
5248 yylval.ival = OP_NULL;
5250 s = scan_str(start);
5254 SvREFCNT_dec(PL_lex_stuff);
5255 PL_lex_stuff = Nullsv;
5256 croak("Substitution pattern not terminated");
5259 if (s[-1] == PL_multi_open)
5262 first_start = PL_multi_start;
5266 SvREFCNT_dec(PL_lex_stuff);
5267 PL_lex_stuff = Nullsv;
5269 SvREFCNT_dec(PL_lex_repl);
5270 PL_lex_repl = Nullsv;
5271 croak("Substitution replacement not terminated");
5273 PL_multi_start = first_start; /* so whole substitution is taken together */
5275 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5281 else if (strchr("iogcmsx", *s))
5282 pmflag(&pm->op_pmflags,*s++);
5289 pm->op_pmflags |= PMf_EVAL;
5290 repl = newSVpv("",0);
5292 sv_catpv(repl, es ? "eval " : "do ");
5293 sv_catpvn(repl, "{ ", 2);
5294 sv_catsv(repl, PL_lex_repl);
5295 sv_catpvn(repl, " };", 2);
5296 SvCOMPILED_on(repl);
5297 SvREFCNT_dec(PL_lex_repl);
5301 pm->op_pmpermflags = pm->op_pmflags;
5302 PL_lex_op = (OP*)pm;
5303 yylval.ival = OP_SUBST;
5308 scan_trans(char *start)
5319 yylval.ival = OP_NULL;
5321 s = scan_str(start);
5324 SvREFCNT_dec(PL_lex_stuff);
5325 PL_lex_stuff = Nullsv;
5326 croak("Transliteration pattern not terminated");
5328 if (s[-1] == PL_multi_open)
5334 SvREFCNT_dec(PL_lex_stuff);
5335 PL_lex_stuff = Nullsv;
5337 SvREFCNT_dec(PL_lex_repl);
5338 PL_lex_repl = Nullsv;
5339 croak("Transliteration replacement not terminated");
5343 o = newSVOP(OP_TRANS, 0, 0);
5344 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5347 New(803,tbl,256,short);
5348 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5352 complement = del = squash = 0;
5353 while (strchr("cdsCU", *s)) {
5355 complement = OPpTRANS_COMPLEMENT;
5357 del = OPpTRANS_DELETE;
5359 squash = OPpTRANS_SQUASH;
5364 utf8 &= ~OPpTRANS_FROM_UTF;
5366 utf8 |= OPpTRANS_FROM_UTF;
5370 utf8 &= ~OPpTRANS_TO_UTF;
5372 utf8 |= OPpTRANS_TO_UTF;
5375 croak("Too many /C and /U options");
5380 o->op_private = del|squash|complement|utf8;
5383 yylval.ival = OP_TRANS;
5388 scan_heredoc(register char *s)
5392 I32 op_type = OP_SCALAR;
5399 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5403 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5406 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5407 if (*peek && strchr("`'\"",*peek)) {
5410 s = delimcpy(d, e, s, PL_bufend, term, &len);
5421 deprecate("bare << to mean <<\"\"");
5422 for (; isALNUM(*s); s++) {
5427 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5428 croak("Delimiter for here document is too long");
5431 len = d - PL_tokenbuf;
5432 #ifndef PERL_STRICT_CR
5433 d = strchr(s, '\r');
5437 while (s < PL_bufend) {
5443 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5452 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5457 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5458 herewas = newSVpv(s,PL_bufend-s);
5460 s--, herewas = newSVpv(s,d-s);
5461 s += SvCUR(herewas);
5463 tmpstr = NEWSV(87,79);
5464 sv_upgrade(tmpstr, SVt_PVIV);
5469 else if (term == '`') {
5470 op_type = OP_BACKTICK;
5471 SvIVX(tmpstr) = '\\';
5475 PL_multi_start = PL_curcop->cop_line;
5476 PL_multi_open = PL_multi_close = '<';
5477 term = *PL_tokenbuf;
5480 while (s < PL_bufend &&
5481 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5483 PL_curcop->cop_line++;
5485 if (s >= PL_bufend) {
5486 PL_curcop->cop_line = PL_multi_start;
5487 missingterm(PL_tokenbuf);
5489 sv_setpvn(tmpstr,d+1,s-d);
5491 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5493 sv_catpvn(herewas,s,PL_bufend-s);
5494 sv_setsv(PL_linestr,herewas);
5495 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5496 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5499 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5500 while (s >= PL_bufend) { /* multiple line string? */
5502 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5503 PL_curcop->cop_line = PL_multi_start;
5504 missingterm(PL_tokenbuf);
5506 PL_curcop->cop_line++;
5507 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5508 #ifndef PERL_STRICT_CR
5509 if (PL_bufend - PL_linestart >= 2) {
5510 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5511 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5513 PL_bufend[-2] = '\n';
5515 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5517 else if (PL_bufend[-1] == '\r')
5518 PL_bufend[-1] = '\n';
5520 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5521 PL_bufend[-1] = '\n';
5523 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5524 SV *sv = NEWSV(88,0);
5526 sv_upgrade(sv, SVt_PVMG);
5527 sv_setsv(sv,PL_linestr);
5528 av_store(GvAV(PL_curcop->cop_filegv),
5529 (I32)PL_curcop->cop_line,sv);
5531 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5534 sv_catsv(PL_linestr,herewas);
5535 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5539 sv_catsv(tmpstr,PL_linestr);
5542 PL_multi_end = PL_curcop->cop_line;
5544 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5545 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5546 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5548 SvREFCNT_dec(herewas);
5549 PL_lex_stuff = tmpstr;
5550 yylval.ival = op_type;
5555 takes: current position in input buffer
5556 returns: new position in input buffer
5557 side-effects: yylval and lex_op are set.
5562 <FH> read from filehandle
5563 <pkg::FH> read from package qualified filehandle
5564 <pkg'FH> read from package qualified filehandle
5565 <$fh> read from filehandle in $fh
5571 scan_inputsymbol(char *start)
5573 register char *s = start; /* current position in buffer */
5578 d = PL_tokenbuf; /* start of temp holding space */
5579 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5580 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5582 /* die if we didn't have space for the contents of the <>,
5586 if (len >= sizeof PL_tokenbuf)
5587 croak("Excessively long <> operator");
5589 croak("Unterminated <> operator");
5594 Remember, only scalar variables are interpreted as filehandles by
5595 this code. Anything more complex (e.g., <$fh{$num}>) will be
5596 treated as a glob() call.
5597 This code makes use of the fact that except for the $ at the front,
5598 a scalar variable and a filehandle look the same.
5600 if (*d == '$' && d[1]) d++;
5602 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5603 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5606 /* If we've tried to read what we allow filehandles to look like, and
5607 there's still text left, then it must be a glob() and not a getline.
5608 Use scan_str to pull out the stuff between the <> and treat it
5609 as nothing more than a string.
5612 if (d - PL_tokenbuf != len) {
5613 yylval.ival = OP_GLOB;
5615 s = scan_str(start);
5617 croak("Glob not terminated");
5621 /* we're in a filehandle read situation */
5624 /* turn <> into <ARGV> */
5626 (void)strcpy(d,"ARGV");
5628 /* if <$fh>, create the ops to turn the variable into a
5634 /* try to find it in the pad for this block, otherwise find
5635 add symbol table ops
5637 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5638 OP *o = newOP(OP_PADSV, 0);
5640 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5643 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5644 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5645 newUNOP(OP_RV2GV, 0,
5646 newUNOP(OP_RV2SV, 0,
5647 newGVOP(OP_GV, 0, gv))));
5649 /* we created the ops in lex_op, so make yylval.ival a null op */
5650 yylval.ival = OP_NULL;
5653 /* If it's none of the above, it must be a literal filehandle
5654 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5656 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5657 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5658 yylval.ival = OP_NULL;
5667 takes: start position in buffer
5668 returns: position to continue reading from buffer
5669 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5670 updates the read buffer.
5672 This subroutine pulls a string out of the input. It is called for:
5673 q single quotes q(literal text)
5674 ' single quotes 'literal text'
5675 qq double quotes qq(interpolate $here please)
5676 " double quotes "interpolate $here please"
5677 qx backticks qx(/bin/ls -l)
5678 ` backticks `/bin/ls -l`
5679 qw quote words @EXPORT_OK = qw( func() $spam )
5680 m// regexp match m/this/
5681 s/// regexp substitute s/this/that/
5682 tr/// string transliterate tr/this/that/
5683 y/// string transliterate y/this/that/
5684 ($*@) sub prototypes sub foo ($)
5685 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5687 In most of these cases (all but <>, patterns and transliterate)
5688 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5689 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5690 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5693 It skips whitespace before the string starts, and treats the first
5694 character as the delimiter. If the delimiter is one of ([{< then
5695 the corresponding "close" character )]}> is used as the closing
5696 delimiter. It allows quoting of delimiters, and if the string has
5697 balanced delimiters ([{<>}]) it allows nesting.
5699 The lexer always reads these strings into lex_stuff, except in the
5700 case of the operators which take *two* arguments (s/// and tr///)
5701 when it checks to see if lex_stuff is full (presumably with the 1st
5702 arg to s or tr) and if so puts the string into lex_repl.
5707 scan_str(char *start)
5710 SV *sv; /* scalar value: string */
5711 char *tmps; /* temp string, used for delimiter matching */
5712 register char *s = start; /* current position in the buffer */
5713 register char term; /* terminating character */
5714 register char *to; /* current position in the sv's data */
5715 I32 brackets = 1; /* bracket nesting level */
5717 /* skip space before the delimiter */
5721 /* mark where we are, in case we need to report errors */
5724 /* after skipping whitespace, the next character is the terminator */
5726 /* mark where we are */
5727 PL_multi_start = PL_curcop->cop_line;
5728 PL_multi_open = term;
5730 /* find corresponding closing delimiter */
5731 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5733 PL_multi_close = term;
5735 /* create a new SV to hold the contents. 87 is leak category, I'm
5736 assuming. 79 is the SV's initial length. What a random number. */
5738 sv_upgrade(sv, SVt_PVIV);
5740 (void)SvPOK_only(sv); /* validate pointer */
5742 /* move past delimiter and try to read a complete string */
5745 /* extend sv if need be */
5746 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5747 /* set 'to' to the next character in the sv's string */
5748 to = SvPVX(sv)+SvCUR(sv);
5750 /* if open delimiter is the close delimiter read unbridle */
5751 if (PL_multi_open == PL_multi_close) {
5752 for (; s < PL_bufend; s++,to++) {
5753 /* embedded newlines increment the current line number */
5754 if (*s == '\n' && !PL_rsfp)
5755 PL_curcop->cop_line++;
5756 /* handle quoted delimiters */
5757 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5760 /* any other quotes are simply copied straight through */
5764 /* terminate when run out of buffer (the for() condition), or
5765 have found the terminator */
5766 else if (*s == term)
5772 /* if the terminator isn't the same as the start character (e.g.,
5773 matched brackets), we have to allow more in the quoting, and
5774 be prepared for nested brackets.
5777 /* read until we run out of string, or we find the terminator */
5778 for (; s < PL_bufend; s++,to++) {
5779 /* embedded newlines increment the line count */
5780 if (*s == '\n' && !PL_rsfp)
5781 PL_curcop->cop_line++;
5782 /* backslashes can escape the open or closing characters */
5783 if (*s == '\\' && s+1 < PL_bufend) {
5784 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5789 /* allow nested opens and closes */
5790 else if (*s == PL_multi_close && --brackets <= 0)
5792 else if (*s == PL_multi_open)
5797 /* terminate the copied string and update the sv's end-of-string */
5799 SvCUR_set(sv, to - SvPVX(sv));
5802 * this next chunk reads more into the buffer if we're not done yet
5805 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5807 #ifndef PERL_STRICT_CR
5808 if (to - SvPVX(sv) >= 2) {
5809 if ((to[-2] == '\r' && to[-1] == '\n') ||
5810 (to[-2] == '\n' && to[-1] == '\r'))
5814 SvCUR_set(sv, to - SvPVX(sv));
5816 else if (to[-1] == '\r')
5819 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5823 /* if we're out of file, or a read fails, bail and reset the current
5824 line marker so we can report where the unterminated string began
5827 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5829 PL_curcop->cop_line = PL_multi_start;
5832 /* we read a line, so increment our line counter */
5833 PL_curcop->cop_line++;
5835 /* update debugger info */
5836 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5837 SV *sv = NEWSV(88,0);
5839 sv_upgrade(sv, SVt_PVMG);
5840 sv_setsv(sv,PL_linestr);
5841 av_store(GvAV(PL_curcop->cop_filegv),
5842 (I32)PL_curcop->cop_line, sv);
5845 /* having changed the buffer, we must update PL_bufend */
5846 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5849 /* at this point, we have successfully read the delimited string */
5851 PL_multi_end = PL_curcop->cop_line;
5854 /* if we allocated too much space, give some back */
5855 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5856 SvLEN_set(sv, SvCUR(sv) + 1);
5857 Renew(SvPVX(sv), SvLEN(sv), char);
5860 /* decide whether this is the first or second quoted string we've read
5873 takes: pointer to position in buffer
5874 returns: pointer to new position in buffer
5875 side-effects: builds ops for the constant in yylval.op
5877 Read a number in any of the formats that Perl accepts:
5879 0(x[0-7A-F]+)|([0-7]+)
5880 [\d_]+(\.[\d_]*)?[Ee](\d+)
5882 Underbars (_) are allowed in decimal numbers. If -w is on,
5883 underbars before a decimal point must be at three digit intervals.
5885 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5888 If it reads a number without a decimal point or an exponent, it will
5889 try converting the number to an integer and see if it can do so
5890 without loss of precision.
5894 scan_num(char *start)
5896 register char *s = start; /* current position in buffer */
5897 register char *d; /* destination in temp buffer */
5898 register char *e; /* end of temp buffer */
5899 I32 tryiv; /* used to see if it can be an int */
5900 double value; /* number read, as a double */
5901 SV *sv; /* place to put the converted number */
5902 I32 floatit; /* boolean: int or float? */
5903 char *lastub = 0; /* position of last underbar */
5904 static char number_too_long[] = "Number too long";
5906 /* We use the first character to decide what type of number this is */
5910 croak("panic: scan_num");
5912 /* if it starts with a 0, it could be an octal number, a decimal in
5913 0.13 disguise, or a hexadecimal number.
5918 u holds the "number so far"
5919 shift the power of 2 of the base (hex == 4, octal == 3)
5920 overflowed was the number more than we can hold?
5922 Shift is used when we add a digit. It also serves as an "are
5923 we in octal or hex?" indicator to disallow hex characters when
5928 bool overflowed = FALSE;
5935 /* check for a decimal in disguise */
5936 else if (s[1] == '.')
5938 /* so it must be octal */
5943 /* read the rest of the octal number */
5945 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5949 /* if we don't mention it, we're done */
5958 /* 8 and 9 are not octal */
5961 yyerror("Illegal octal digit");
5965 case '0': case '1': case '2': case '3': case '4':
5966 case '5': case '6': case '7':
5967 b = *s++ & 15; /* ASCII digit -> value of digit */
5971 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5972 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5973 /* make sure they said 0x */
5978 /* Prepare to put the digit we have onto the end
5979 of the number so far. We check for overflows.
5983 n = u << shift; /* make room for the digit */
5984 if (!overflowed && (n >> shift) != u
5985 && !(PL_hints & HINT_NEW_BINARY)) {
5986 warn("Integer overflow in %s number",
5987 (shift == 4) ? "hex" : "octal");
5990 u = n | b; /* add the digit to the end */
5995 /* if we get here, we had success: make a scalar value from
6001 if ( PL_hints & HINT_NEW_BINARY)
6002 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6007 handle decimal numbers.
6008 we're also sent here when we read a 0 as the first digit
6010 case '1': case '2': case '3': case '4': case '5':
6011 case '6': case '7': case '8': case '9': case '.':
6014 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6017 /* read next group of digits and _ and copy into d */
6018 while (isDIGIT(*s) || *s == '_') {
6019 /* skip underscores, checking for misplaced ones
6023 dTHR; /* only for ckWARN */
6024 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6025 warner(WARN_SYNTAX, "Misplaced _ in number");
6029 /* check for end of fixed-length buffer */
6031 croak(number_too_long);
6032 /* if we're ok, copy the character */
6037 /* final misplaced underbar check */
6038 if (lastub && s - lastub != 3) {
6040 if (ckWARN(WARN_SYNTAX))
6041 warner(WARN_SYNTAX, "Misplaced _ in number");
6044 /* read a decimal portion if there is one. avoid
6045 3..5 being interpreted as the number 3. followed
6048 if (*s == '.' && s[1] != '.') {
6052 /* copy, ignoring underbars, until we run out of
6053 digits. Note: no misplaced underbar checks!
6055 for (; isDIGIT(*s) || *s == '_'; s++) {
6056 /* fixed length buffer check */
6058 croak(number_too_long);
6064 /* read exponent part, if present */
6065 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6069 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6070 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6072 /* allow positive or negative exponent */
6073 if (*s == '+' || *s == '-')
6076 /* read digits of exponent (no underbars :-) */
6077 while (isDIGIT(*s)) {
6079 croak(number_too_long);
6084 /* terminate the string */
6087 /* make an sv from the string */
6089 /* reset numeric locale in case we were earlier left in Swaziland */
6090 SET_NUMERIC_STANDARD();
6091 value = atof(PL_tokenbuf);
6094 See if we can make do with an integer value without loss of
6095 precision. We use I_V to cast to an int, because some
6096 compilers have issues. Then we try casting it back and see
6097 if it was the same. We only do this if we know we
6098 specifically read an integer.
6100 Note: if floatit is true, then we don't need to do the
6104 if (!floatit && (double)tryiv == value)
6105 sv_setiv(sv, tryiv);
6107 sv_setnv(sv, value);
6108 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6109 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6110 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6114 /* make the op for the constant and return */
6116 yylval.opval = newSVOP(OP_CONST, 0, sv);
6122 scan_formline(register char *s)
6127 SV *stuff = newSVpv("",0);
6128 bool needargs = FALSE;
6131 if (*s == '.' || *s == '}') {
6133 #ifdef PERL_STRICT_CR
6134 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6136 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6141 if (PL_in_eval && !PL_rsfp) {
6142 eol = strchr(s,'\n');
6147 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6149 for (t = s; t < eol; t++) {
6150 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6152 goto enough; /* ~~ must be first line in formline */
6154 if (*t == '@' || *t == '^')
6157 sv_catpvn(stuff, s, eol-s);
6161 s = filter_gets(PL_linestr, PL_rsfp, 0);
6162 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6163 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6166 yyerror("Format not terminated");
6176 PL_lex_state = LEX_NORMAL;
6177 PL_nextval[PL_nexttoke].ival = 0;
6181 PL_lex_state = LEX_FORMLINE;
6182 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6184 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6188 SvREFCNT_dec(stuff);
6189 PL_lex_formbrack = 0;
6200 PL_cshlen = strlen(PL_cshname);
6205 start_subparse(I32 is_format, U32 flags)
6208 I32 oldsavestack_ix = PL_savestack_ix;
6209 CV* outsidecv = PL_compcv;
6213 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6215 save_I32(&PL_subline);
6216 save_item(PL_subname);
6218 SAVESPTR(PL_curpad);
6219 SAVESPTR(PL_comppad);
6220 SAVESPTR(PL_comppad_name);
6221 SAVESPTR(PL_compcv);
6222 SAVEI32(PL_comppad_name_fill);
6223 SAVEI32(PL_min_intro_pending);
6224 SAVEI32(PL_max_intro_pending);
6225 SAVEI32(PL_pad_reset_pending);
6227 PL_compcv = (CV*)NEWSV(1104,0);
6228 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6229 CvFLAGS(PL_compcv) |= flags;
6231 PL_comppad = newAV();
6232 av_push(PL_comppad, Nullsv);
6233 PL_curpad = AvARRAY(PL_comppad);
6234 PL_comppad_name = newAV();
6235 PL_comppad_name_fill = 0;
6236 PL_min_intro_pending = 0;
6238 PL_subline = PL_curcop->cop_line;
6240 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6241 PL_curpad[0] = (SV*)newAV();
6242 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6243 #endif /* USE_THREADS */
6245 comppadlist = newAV();
6246 AvREAL_off(comppadlist);
6247 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6248 av_store(comppadlist, 1, (SV*)PL_comppad);
6250 CvPADLIST(PL_compcv) = comppadlist;
6251 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6253 CvOWNER(PL_compcv) = 0;
6254 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6255 MUTEX_INIT(CvMUTEXP(PL_compcv));
6256 #endif /* USE_THREADS */
6258 return oldsavestack_ix;
6277 char *context = NULL;
6281 if (!yychar || (yychar == ';' && !PL_rsfp))
6283 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6284 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6285 while (isSPACE(*PL_oldoldbufptr))
6287 context = PL_oldoldbufptr;
6288 contlen = PL_bufptr - PL_oldoldbufptr;
6290 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6291 PL_oldbufptr != PL_bufptr) {
6292 while (isSPACE(*PL_oldbufptr))
6294 context = PL_oldbufptr;
6295 contlen = PL_bufptr - PL_oldbufptr;
6297 else if (yychar > 255)
6298 where = "next token ???";
6299 else if ((yychar & 127) == 127) {
6300 if (PL_lex_state == LEX_NORMAL ||
6301 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6302 where = "at end of line";
6303 else if (PL_lex_inpat)
6304 where = "within pattern";
6306 where = "within string";
6309 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6311 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6312 else if (isPRINT_LC(yychar))
6313 sv_catpvf(where_sv, "%c", yychar);
6315 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6316 where = SvPVX(where_sv);
6318 msg = sv_2mortal(newSVpv(s, 0));
6319 sv_catpvf(msg, " at %_ line %ld, ",
6320 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6322 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6324 sv_catpvf(msg, "%s\n", where);
6325 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6327 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6328 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6333 else if (PL_in_eval)
6334 sv_catsv(ERRSV, msg);
6336 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6337 if (++PL_error_count >= 10)
6338 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6340 PL_in_my_stash = Nullhv;