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 * Note: we try to be careful never to call the isXXX_utf8() functions
66 * unless we're pretty sure we've seen the beginning of a UTF-8 character
67 * (that is, the two high bits are set). Otherwise we risk loading in the
68 * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
70 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
72 : isIDFIRST_utf8((U8*)p))
73 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
75 : isALNUM_utf8((U8*)p))
77 /* The following are arranged oddly so that the guard on the switch statement
78 * can get by with a single comparison (if the compiler is smart enough).
81 /* #define LEX_NOTPARSING 11 is done in perl.h. */
84 #define LEX_INTERPNORMAL 9
85 #define LEX_INTERPCASEMOD 8
86 #define LEX_INTERPPUSH 7
87 #define LEX_INTERPSTART 6
88 #define LEX_INTERPEND 5
89 #define LEX_INTERPENDMAYBE 4
90 #define LEX_INTERPCONCAT 3
91 #define LEX_INTERPCONST 2
92 #define LEX_FORMLINE 1
93 #define LEX_KNOWNEXT 0
102 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
104 # include <unistd.h> /* Needed for execv() */
112 #ifdef USE_PURE_BISON
113 YYSTYPE* yylval_pointer = NULL;
114 int* yychar_pointer = NULL;
119 # define yylval (*yylval_pointer)
120 # define yychar (*yychar_pointer)
121 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
123 # define PERL_YYLEX_PARAM
126 #include "keywords.h"
131 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
133 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
134 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
135 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
136 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
137 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
138 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
139 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
140 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
141 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
142 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
143 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
144 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
145 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
146 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
147 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
148 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
149 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
150 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
151 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
152 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
154 /* This bit of chicanery makes a unary function followed by
155 * a parenthesis into a function with one argument, highest precedence.
157 #define UNI(f) return(yylval.ival = f, \
160 PL_last_uni = PL_oldbufptr, \
161 PL_last_lop_op = f, \
162 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
164 #define UNIBRACK(f) return(yylval.ival = f, \
166 PL_last_uni = PL_oldbufptr, \
167 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
169 /* grandfather return to old style */
170 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
175 if (*PL_bufptr == '=') {
177 if (toketype == ANDAND)
178 yylval.ival = OP_ANDASSIGN;
179 else if (toketype == OROR)
180 yylval.ival = OP_ORASSIGN;
187 no_op(char *what, char *s)
189 char *oldbp = PL_bufptr;
190 bool is_first = (PL_oldbufptr == PL_linestart);
193 yywarn(form("%s found where operator expected", what));
195 warn("\t(Missing semicolon on previous line?)\n");
196 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
198 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
199 if (t < PL_bufptr && isSPACE(*t))
200 warn("\t(Do you need to predeclare %.*s?)\n",
201 t - PL_oldoldbufptr, PL_oldoldbufptr);
205 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
215 char *nl = strrchr(s,'\n');
221 iscntrl(PL_multi_close)
223 PL_multi_close < 32 || PL_multi_close == 127
227 tmpbuf[1] = toCTRL(PL_multi_close);
233 *tmpbuf = PL_multi_close;
237 q = strchr(s,'"') ? '\'' : '"';
238 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
245 if (ckWARN(WARN_DEPRECATED))
246 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
252 deprecate("comma-less variable list");
258 win32_textfilter(int idx, SV *sv, int maxlen)
260 I32 count = FILTER_READ(idx+1, sv, maxlen);
261 if (count > 0 && !maxlen)
262 win32_strip_return(sv);
270 utf16_textfilter(int idx, SV *sv, int maxlen)
272 I32 count = FILTER_READ(idx+1, sv, maxlen);
276 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
277 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
278 sv_usepvn(sv, (char*)tmps, tend - tmps);
285 utf16rev_textfilter(int idx, SV *sv, int maxlen)
287 I32 count = FILTER_READ(idx+1, sv, maxlen);
291 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
292 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
293 sv_usepvn(sv, (char*)tmps, tend - tmps);
308 SAVEI32(PL_lex_dojoin);
309 SAVEI32(PL_lex_brackets);
310 SAVEI32(PL_lex_fakebrack);
311 SAVEI32(PL_lex_casemods);
312 SAVEI32(PL_lex_starts);
313 SAVEI32(PL_lex_state);
314 SAVESPTR(PL_lex_inpat);
315 SAVEI32(PL_lex_inwhat);
316 SAVEI16(PL_curcop->cop_line);
319 SAVEPPTR(PL_oldbufptr);
320 SAVEPPTR(PL_oldoldbufptr);
321 SAVEPPTR(PL_linestart);
322 SAVESPTR(PL_linestr);
323 SAVEPPTR(PL_lex_brackstack);
324 SAVEPPTR(PL_lex_casestack);
325 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
326 SAVESPTR(PL_lex_stuff);
327 SAVEI32(PL_lex_defer);
328 SAVESPTR(PL_lex_repl);
329 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
330 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
332 PL_lex_state = LEX_NORMAL;
336 PL_lex_fakebrack = 0;
337 New(899, PL_lex_brackstack, 120, char);
338 New(899, PL_lex_casestack, 12, char);
339 SAVEFREEPV(PL_lex_brackstack);
340 SAVEFREEPV(PL_lex_casestack);
342 *PL_lex_casestack = '\0';
345 PL_lex_stuff = Nullsv;
346 PL_lex_repl = Nullsv;
350 if (SvREADONLY(PL_linestr))
351 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
352 s = SvPV(PL_linestr, len);
353 if (len && s[len-1] != ';') {
354 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
355 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
356 sv_catpvn(PL_linestr, "\n;", 2);
358 SvTEMP_off(PL_linestr);
359 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
360 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
362 PL_rs = newSVpv("\n", 1);
369 PL_doextract = FALSE;
373 restore_rsfp(void *f)
375 PerlIO *fp = (PerlIO*)f;
377 if (PL_rsfp == PerlIO_stdin())
378 PerlIO_clearerr(PL_rsfp);
379 else if (PL_rsfp && (PL_rsfp != fp))
380 PerlIO_close(PL_rsfp);
385 restore_expect(void *e)
387 /* a safe way to store a small integer in a pointer */
388 PL_expect = (expectation)((char *)e - PL_tokenbuf);
392 restore_lex_expect(void *e)
394 /* a safe way to store a small integer in a pointer */
395 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
407 PL_curcop->cop_line++;
410 while (*s == ' ' || *s == '\t') s++;
411 if (strnEQ(s, "line ", 5)) {
420 while (*s == ' ' || *s == '\t')
422 if (*s == '"' && (t = strchr(s+1, '"')))
426 return; /* false alarm */
427 for (t = s; !isSPACE(*t); t++) ;
432 PL_curcop->cop_filegv = gv_fetchfile(s);
434 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
436 PL_curcop->cop_line = atoi(n)-1;
440 skipspace(register char *s)
443 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
444 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
450 while (s < PL_bufend && isSPACE(*s))
452 if (s < PL_bufend && *s == '#') {
453 while (s < PL_bufend && *s != '\n')
458 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
460 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
461 if (PL_minus_n || PL_minus_p) {
462 sv_setpv(PL_linestr,PL_minus_p ?
463 ";}continue{print or die qq(-p destination: $!\\n)" :
465 sv_catpv(PL_linestr,";}");
466 PL_minus_n = PL_minus_p = 0;
469 sv_setpv(PL_linestr,";");
470 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
471 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
472 if (PL_preprocess && !PL_in_eval)
473 (void)PerlProc_pclose(PL_rsfp);
474 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
475 PerlIO_clearerr(PL_rsfp);
477 (void)PerlIO_close(PL_rsfp);
481 PL_linestart = PL_bufptr = s + prevlen;
482 PL_bufend = s + SvCUR(PL_linestr);
485 if (PERLDB_LINE && PL_curstash != PL_debstash) {
486 SV *sv = NEWSV(85,0);
488 sv_upgrade(sv, SVt_PVMG);
489 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
490 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
501 if (PL_oldoldbufptr != PL_last_uni)
503 while (isSPACE(*PL_last_uni))
505 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
506 if ((t = strchr(s, '(')) && t < PL_bufptr)
510 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
517 #define UNI(f) return uni(f,s)
525 PL_last_uni = PL_oldbufptr;
536 #endif /* CRIPPLED_CC */
538 #define LOP(f,x) return lop(f,x,s)
541 lop(I32 f, expectation x, char *s)
548 PL_last_lop = PL_oldbufptr;
564 PL_nexttype[PL_nexttoke] = type;
566 if (PL_lex_state != LEX_KNOWNEXT) {
567 PL_lex_defer = PL_lex_state;
568 PL_lex_expect = PL_expect;
569 PL_lex_state = LEX_KNOWNEXT;
574 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
579 start = skipspace(start);
581 if (isIDFIRST_lazy(s) ||
582 (allow_pack && *s == ':') ||
583 (allow_initial_tick && *s == '\'') )
585 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
586 if (check_keyword && keyword(PL_tokenbuf, len))
588 if (token == METHOD) {
593 PL_expect = XOPERATOR;
598 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
599 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
606 force_ident(register char *s, int kind)
609 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
610 PL_nextval[PL_nexttoke].opval = o;
613 dTHR; /* just for in_eval */
614 o->op_private = OPpCONST_ENTERED;
615 /* XXX see note in pp_entereval() for why we forgo typo
616 warnings if the symbol must be introduced in an eval.
618 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
619 kind == '$' ? SVt_PV :
620 kind == '@' ? SVt_PVAV :
621 kind == '%' ? SVt_PVHV :
629 force_version(char *s)
631 OP *version = Nullop;
635 /* default VERSION number -- GBARR */
640 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
641 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
643 /* real VERSION number -- GBARR */
644 version = yylval.opval;
648 /* NOTE: The parser sees the package name and the VERSION swapped */
649 PL_nextval[PL_nexttoke].opval = version;
667 s = SvPV_force(sv, len);
671 while (s < send && *s != '\\')
676 if ( PL_hints & HINT_NEW_STRING )
677 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
680 if (s + 1 < send && (s[1] == '\\'))
681 s++; /* all that, just for this */
686 SvCUR_set(sv, d - SvPVX(sv));
688 if ( PL_hints & HINT_NEW_STRING )
689 return new_constant(NULL, 0, "q", sv, pv, "q");
696 register I32 op_type = yylval.ival;
698 if (op_type == OP_NULL) {
699 yylval.opval = PL_lex_op;
703 if (op_type == OP_CONST || op_type == OP_READLINE) {
704 SV *sv = tokeq(PL_lex_stuff);
706 if (SvTYPE(sv) == SVt_PVIV) {
707 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
713 nsv = newSVpv(p, len);
717 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
718 PL_lex_stuff = Nullsv;
722 PL_sublex_info.super_state = PL_lex_state;
723 PL_sublex_info.sub_inwhat = op_type;
724 PL_sublex_info.sub_op = PL_lex_op;
725 PL_lex_state = LEX_INTERPPUSH;
729 yylval.opval = PL_lex_op;
743 PL_lex_state = PL_sublex_info.super_state;
744 SAVEI32(PL_lex_dojoin);
745 SAVEI32(PL_lex_brackets);
746 SAVEI32(PL_lex_fakebrack);
747 SAVEI32(PL_lex_casemods);
748 SAVEI32(PL_lex_starts);
749 SAVEI32(PL_lex_state);
750 SAVESPTR(PL_lex_inpat);
751 SAVEI32(PL_lex_inwhat);
752 SAVEI16(PL_curcop->cop_line);
754 SAVEPPTR(PL_oldbufptr);
755 SAVEPPTR(PL_oldoldbufptr);
756 SAVEPPTR(PL_linestart);
757 SAVESPTR(PL_linestr);
758 SAVEPPTR(PL_lex_brackstack);
759 SAVEPPTR(PL_lex_casestack);
761 PL_linestr = PL_lex_stuff;
762 PL_lex_stuff = Nullsv;
764 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
765 PL_bufend += SvCUR(PL_linestr);
766 SAVEFREESV(PL_linestr);
768 PL_lex_dojoin = FALSE;
770 PL_lex_fakebrack = 0;
771 New(899, PL_lex_brackstack, 120, char);
772 New(899, PL_lex_casestack, 12, char);
773 SAVEFREEPV(PL_lex_brackstack);
774 SAVEFREEPV(PL_lex_casestack);
776 *PL_lex_casestack = '\0';
778 PL_lex_state = LEX_INTERPCONCAT;
779 PL_curcop->cop_line = PL_multi_start;
781 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
782 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
783 PL_lex_inpat = PL_sublex_info.sub_op;
785 PL_lex_inpat = Nullop;
793 if (!PL_lex_starts++) {
794 PL_expect = XOPERATOR;
795 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
799 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
800 PL_lex_state = LEX_INTERPCASEMOD;
801 return yylex(PERL_YYLEX_PARAM);
804 /* Is there a right-hand side to take care of? */
805 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
806 PL_linestr = PL_lex_repl;
808 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
809 PL_bufend += SvCUR(PL_linestr);
810 SAVEFREESV(PL_linestr);
811 PL_lex_dojoin = FALSE;
813 PL_lex_fakebrack = 0;
815 *PL_lex_casestack = '\0';
817 if (SvCOMPILED(PL_lex_repl)) {
818 PL_lex_state = LEX_INTERPNORMAL;
822 PL_lex_state = LEX_INTERPCONCAT;
823 PL_lex_repl = Nullsv;
828 PL_bufend = SvPVX(PL_linestr);
829 PL_bufend += SvCUR(PL_linestr);
830 PL_expect = XOPERATOR;
838 Extracts a pattern, double-quoted string, or transliteration. This
841 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
842 processing a pattern (PL_lex_inpat is true), a transliteration
843 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
845 Returns a pointer to the character scanned up to. Iff this is
846 advanced from the start pointer supplied (ie if anything was
847 successfully parsed), will leave an OP for the substring scanned
848 in yylval. Caller must intuit reason for not parsing further
849 by looking at the next characters herself.
853 double-quoted style: \r and \n
854 regexp special ones: \D \s
856 backrefs: \1 (deprecated in substitution replacements)
857 case and quoting: \U \Q \E
858 stops on @ and $, but not for $ as tail anchor
861 characters are VERY literal, except for - not at the start or end
862 of the string, which indicates a range. scan_const expands the
863 range to the full set of intermediate characters.
865 In double-quoted strings:
867 double-quoted style: \r and \n
869 backrefs: \1 (deprecated)
870 case and quoting: \U \Q \E
873 scan_const does *not* construct ops to handle interpolated strings.
874 It stops processing as soon as it finds an embedded $ or @ variable
875 and leaves it to the caller to work out what's going on.
877 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
879 $ in pattern could be $foo or could be tail anchor. Assumption:
880 it's a tail anchor if $ is the last thing in the string, or if it's
881 followed by one of ")| \n\t"
883 \1 (backreferences) are turned into $1
885 The structure of the code is
886 while (there's a character to process) {
887 handle transliteration ranges
889 skip # initiated comments in //x patterns
890 check for embedded @foo
891 check for embedded scalars
893 leave intact backslashes from leave (below)
894 deprecate \1 in strings and sub replacements
895 handle string-changing backslashes \l \U \Q \E, etc.
896 switch (what was escaped) {
897 handle - in a transliteration (becomes a literal -)
898 handle \132 octal characters
899 handle 0x15 hex characters
900 handle \cV (control V)
901 handle printf backslashes (\f, \r, \n, etc)
904 } (end while character to read)
909 scan_const(char *start)
911 register char *send = PL_bufend; /* end of the constant */
912 SV *sv = NEWSV(93, send - start); /* sv for the constant */
913 register char *s = start; /* start of the constant */
914 register char *d = SvPVX(sv); /* destination for copies */
915 bool dorange = FALSE; /* are we in a translit range? */
917 I32 utf = PL_lex_inwhat == OP_TRANS
918 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
920 I32 thisutf = PL_lex_inwhat == OP_TRANS
921 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
924 /* leaveit is the set of acceptably-backslashed characters */
927 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
930 while (s < send || dorange) {
931 /* get transliterations out of the way (they're most literal) */
932 if (PL_lex_inwhat == OP_TRANS) {
933 /* expand a range A-Z to the full set of characters. AIE! */
935 I32 i; /* current expanded character */
936 I32 min; /* first character in range */
937 I32 max; /* last character in range */
939 i = d - SvPVX(sv); /* remember current offset */
940 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
941 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
942 d -= 2; /* eat the first char and the - */
944 min = (U8)*d; /* first char in range */
945 max = (U8)d[1]; /* last char in range */
948 if ((isLOWER(min) && isLOWER(max)) ||
949 (isUPPER(min) && isUPPER(max))) {
951 for (i = min; i <= max; i++)
955 for (i = min; i <= max; i++)
962 for (i = min; i <= max; i++)
965 /* mark the range as done, and continue */
970 /* range begins (ignore - as first or last char) */
971 else if (*s == '-' && s+1 < send && s != start) {
973 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
982 /* if we get here, we're not doing a transliteration */
984 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
985 except for the last char, which will be done separately. */
986 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
988 while (s < send && *s != ')')
990 } else if (s[2] == '{'
991 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
993 char *regparse = s + (s[2] == '{' ? 3 : 4);
996 while (count && (c = *regparse)) {
997 if (c == '\\' && regparse[1])
1005 if (*regparse != ')') {
1006 regparse--; /* Leave one char for continuation. */
1007 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1009 while (s < regparse)
1014 /* likewise skip #-initiated comments in //x patterns */
1015 else if (*s == '#' && PL_lex_inpat &&
1016 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1017 while (s+1 < send && *s != '\n')
1021 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1022 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1025 /* check for embedded scalars. only stop if we're sure it's a
1028 else if (*s == '$') {
1029 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1031 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1032 break; /* in regexp, $ might be tail anchor */
1035 /* (now in tr/// code again) */
1037 if (*s & 0x80 && thisutf) {
1038 dTHR; /* only for ckWARN */
1039 if (ckWARN(WARN_UTF8)) {
1040 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1050 if (*s == '\\' && s+1 < send) {
1053 /* some backslashes we leave behind */
1054 if (*s && strchr(leaveit, *s)) {
1060 /* deprecate \1 in strings and substitution replacements */
1061 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1062 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1064 dTHR; /* only for ckWARN */
1065 if (ckWARN(WARN_SYNTAX))
1066 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1071 /* string-change backslash escapes */
1072 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1077 /* if we get here, it's either a quoted -, or a digit */
1080 /* quoted - in transliterations */
1082 if (PL_lex_inwhat == OP_TRANS) {
1087 /* default action is to copy the quoted character */
1092 /* \132 indicates an octal constant */
1093 case '0': case '1': case '2': case '3':
1094 case '4': case '5': case '6': case '7':
1095 *d++ = scan_oct(s, 3, &len);
1099 /* \x24 indicates a hex constant */
1103 char* e = strchr(s, '}');
1106 yyerror("Missing right brace on \\x{}");
1111 if (ckWARN(WARN_UTF8))
1113 "Use of \\x{} without utf8 declaration");
1115 /* note: utf always shorter than hex */
1116 d = (char*)uv_to_utf8((U8*)d,
1117 scan_hex(s + 1, e - s - 1, &len));
1122 UV uv = (UV)scan_hex(s, 2, &len);
1123 if (utf && PL_lex_inwhat == OP_TRANS &&
1124 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1126 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1129 if (uv >= 127 && UTF) {
1131 if (ckWARN(WARN_UTF8))
1133 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1142 /* \c is a control character */
1156 /* printf-style backslashes, formfeeds, newlines, etc */
1182 } /* end if (backslash) */
1185 } /* while loop to process each character */
1187 /* terminate the string and set up the sv */
1189 SvCUR_set(sv, d - SvPVX(sv));
1192 /* shrink the sv if we allocated more than we used */
1193 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1194 SvLEN_set(sv, SvCUR(sv) + 1);
1195 Renew(SvPVX(sv), SvLEN(sv), char);
1198 /* return the substring (via yylval) only if we parsed anything */
1199 if (s > PL_bufptr) {
1200 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1201 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1203 ( PL_lex_inwhat == OP_TRANS
1205 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1208 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1214 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1216 intuit_more(register char *s)
1218 if (PL_lex_brackets)
1220 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1222 if (*s != '{' && *s != '[')
1227 /* In a pattern, so maybe we have {n,m}. */
1244 /* On the other hand, maybe we have a character class */
1247 if (*s == ']' || *s == '^')
1250 int weight = 2; /* let's weigh the evidence */
1252 unsigned char un_char = 255, last_un_char;
1253 char *send = strchr(s,']');
1254 char tmpbuf[sizeof PL_tokenbuf * 4];
1256 if (!send) /* has to be an expression */
1259 Zero(seen,256,char);
1262 else if (isDIGIT(*s)) {
1264 if (isDIGIT(s[1]) && s[2] == ']')
1270 for (; s < send; s++) {
1271 last_un_char = un_char;
1272 un_char = (unsigned char)*s;
1277 weight -= seen[un_char] * 10;
1278 if (isALNUM_lazy(s+1)) {
1279 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1280 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1285 else if (*s == '$' && s[1] &&
1286 strchr("[#!%*<>()-=",s[1])) {
1287 if (/*{*/ strchr("])} =",s[2]))
1296 if (strchr("wds]",s[1]))
1298 else if (seen['\''] || seen['"'])
1300 else if (strchr("rnftbxcav",s[1]))
1302 else if (isDIGIT(s[1])) {
1304 while (s[1] && isDIGIT(s[1]))
1314 if (strchr("aA01! ",last_un_char))
1316 if (strchr("zZ79~",s[1]))
1318 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1319 weight -= 5; /* cope with negative subscript */
1322 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1323 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1328 if (keyword(tmpbuf, d - tmpbuf))
1331 if (un_char == last_un_char + 1)
1333 weight -= seen[un_char];
1338 if (weight >= 0) /* probably a character class */
1346 intuit_method(char *start, GV *gv)
1348 char *s = start + (*start == '$');
1349 char tmpbuf[sizeof PL_tokenbuf];
1357 if ((cv = GvCVu(gv))) {
1358 char *proto = SvPVX(cv);
1368 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1369 if (*start == '$') {
1370 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1375 return *s == '(' ? FUNCMETH : METHOD;
1377 if (!keyword(tmpbuf, len)) {
1378 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1383 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1384 if (indirgv && GvCVu(indirgv))
1386 /* filehandle or package name makes it a method */
1387 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1389 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1390 return 0; /* no assumptions -- "=>" quotes bearword */
1392 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1394 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1398 return *s == '(' ? FUNCMETH : METHOD;
1408 char *pdb = PerlEnv_getenv("PERL5DB");
1412 SETERRNO(0,SS$_NORMAL);
1413 return "BEGIN { require 'perl5db.pl' }";
1419 /* Encoded script support. filter_add() effectively inserts a
1420 * 'pre-processing' function into the current source input stream.
1421 * Note that the filter function only applies to the current source file
1422 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1424 * The datasv parameter (which may be NULL) can be used to pass
1425 * private data to this instance of the filter. The filter function
1426 * can recover the SV using the FILTER_DATA macro and use it to
1427 * store private buffers and state information.
1429 * The supplied datasv parameter is upgraded to a PVIO type
1430 * and the IoDIRP field is used to store the function pointer.
1431 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1432 * private use must be set using malloc'd pointers.
1434 static int filter_debug = 0;
1437 filter_add(filter_t funcp, SV *datasv)
1439 if (!funcp){ /* temporary handy debugging hack to be deleted */
1440 filter_debug = atoi((char*)datasv);
1443 if (!PL_rsfp_filters)
1444 PL_rsfp_filters = newAV();
1446 datasv = NEWSV(255,0);
1447 if (!SvUPGRADE(datasv, SVt_PVIO))
1448 die("Can't upgrade filter_add data to SVt_PVIO");
1449 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1451 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1452 av_unshift(PL_rsfp_filters, 1);
1453 av_store(PL_rsfp_filters, 0, datasv) ;
1458 /* Delete most recently added instance of this filter function. */
1460 filter_del(filter_t funcp)
1463 warn("filter_del func %p", funcp);
1464 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1466 /* if filter is on top of stack (usual case) just pop it off */
1467 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1468 sv_free(av_pop(PL_rsfp_filters));
1472 /* we need to search for the correct entry and clear it */
1473 die("filter_del can only delete in reverse order (currently)");
1477 /* Invoke the n'th filter function for the current rsfp. */
1479 filter_read(int idx, SV *buf_sv, int maxlen)
1482 /* 0 = read one text line */
1487 if (!PL_rsfp_filters)
1489 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1490 /* Provide a default input filter to make life easy. */
1491 /* Note that we append to the line. This is handy. */
1493 warn("filter_read %d: from rsfp\n", idx);
1497 int old_len = SvCUR(buf_sv) ;
1499 /* ensure buf_sv is large enough */
1500 SvGROW(buf_sv, old_len + maxlen) ;
1501 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1502 if (PerlIO_error(PL_rsfp))
1503 return -1; /* error */
1505 return 0 ; /* end of file */
1507 SvCUR_set(buf_sv, old_len + len) ;
1510 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1511 if (PerlIO_error(PL_rsfp))
1512 return -1; /* error */
1514 return 0 ; /* end of file */
1517 return SvCUR(buf_sv);
1519 /* Skip this filter slot if filter has been deleted */
1520 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1522 warn("filter_read %d: skipped (filter deleted)\n", idx);
1523 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1525 /* Get function pointer hidden within datasv */
1526 funcp = (filter_t)IoDIRP(datasv);
1528 warn("filter_read %d: via function %p (%s)\n",
1529 idx, funcp, SvPV(datasv,PL_na));
1530 /* Call function. The function is expected to */
1531 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1532 /* Return: <0:error, =0:eof, >0:not eof */
1533 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1537 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1540 if (!PL_rsfp_filters) {
1541 filter_add(win32_textfilter,NULL);
1544 if (PL_rsfp_filters) {
1547 SvCUR_set(sv, 0); /* start with empty line */
1548 if (FILTER_READ(0, sv, 0) > 0)
1549 return ( SvPVX(sv) ) ;
1554 return (sv_gets(sv, fp, append));
1559 static char* exp_name[] =
1560 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1566 Works out what to call the token just pulled out of the input
1567 stream. The yacc parser takes care of taking the ops we return and
1568 stitching them into a tree.
1574 if read an identifier
1575 if we're in a my declaration
1576 croak if they tried to say my($foo::bar)
1577 build the ops for a my() declaration
1578 if it's an access to a my() variable
1579 are we in a sort block?
1580 croak if my($a); $a <=> $b
1581 build ops for access to a my() variable
1582 if in a dq string, and they've said @foo and we can't find @foo
1584 build ops for a bareword
1585 if we already built the token before, use it.
1588 int yylex(PERL_YYLEX_PARAM_DECL)
1598 #ifdef USE_PURE_BISON
1599 yylval_pointer = lvalp;
1600 yychar_pointer = lcharp;
1603 /* check if there's an identifier for us to look at */
1604 if (PL_pending_ident) {
1605 /* pit holds the identifier we read and pending_ident is reset */
1606 char pit = PL_pending_ident;
1607 PL_pending_ident = 0;
1609 /* if we're in a my(), we can't allow dynamics here.
1610 $foo'bar has already been turned into $foo::bar, so
1611 just check for colons.
1613 if it's a legal name, the OP is a PADANY.
1616 if (strchr(PL_tokenbuf,':'))
1617 croak(no_myglob,PL_tokenbuf);
1619 yylval.opval = newOP(OP_PADANY, 0);
1620 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1625 build the ops for accesses to a my() variable.
1627 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1628 then used in a comparison. This catches most, but not
1629 all cases. For instance, it catches
1630 sort { my($a); $a <=> $b }
1632 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1633 (although why you'd do that is anyone's guess).
1636 if (!strchr(PL_tokenbuf,':')) {
1638 /* Check for single character per-thread SVs */
1639 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1640 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1641 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1643 yylval.opval = newOP(OP_THREADSV, 0);
1644 yylval.opval->op_targ = tmp;
1647 #endif /* USE_THREADS */
1648 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1649 /* if it's a sort block and they're naming $a or $b */
1650 if (PL_last_lop_op == OP_SORT &&
1651 PL_tokenbuf[0] == '$' &&
1652 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1655 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1656 d < PL_bufend && *d != '\n';
1659 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1660 croak("Can't use \"my %s\" in sort comparison",
1666 yylval.opval = newOP(OP_PADANY, 0);
1667 yylval.opval->op_targ = tmp;
1673 Whine if they've said @foo in a doublequoted string,
1674 and @foo isn't a variable we can find in the symbol
1677 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1678 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1679 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1680 yyerror(form("In string, %s now must be written as \\%s",
1681 PL_tokenbuf, PL_tokenbuf));
1684 /* build ops for a bareword */
1685 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1686 yylval.opval->op_private = OPpCONST_ENTERED;
1687 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1688 ((PL_tokenbuf[0] == '$') ? SVt_PV
1689 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1694 /* no identifier pending identification */
1696 switch (PL_lex_state) {
1698 case LEX_NORMAL: /* Some compilers will produce faster */
1699 case LEX_INTERPNORMAL: /* code if we comment these out. */
1703 /* when we're already built the next token, just pull it out the queue */
1706 yylval = PL_nextval[PL_nexttoke];
1708 PL_lex_state = PL_lex_defer;
1709 PL_expect = PL_lex_expect;
1710 PL_lex_defer = LEX_NORMAL;
1712 return(PL_nexttype[PL_nexttoke]);
1714 /* interpolated case modifiers like \L \U, including \Q and \E.
1715 when we get here, PL_bufptr is at the \
1717 case LEX_INTERPCASEMOD:
1719 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1720 croak("panic: INTERPCASEMOD");
1722 /* handle \E or end of string */
1723 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1727 if (PL_lex_casemods) {
1728 oldmod = PL_lex_casestack[--PL_lex_casemods];
1729 PL_lex_casestack[PL_lex_casemods] = '\0';
1731 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1733 PL_lex_state = LEX_INTERPCONCAT;
1737 if (PL_bufptr != PL_bufend)
1739 PL_lex_state = LEX_INTERPCONCAT;
1740 return yylex(PERL_YYLEX_PARAM);
1744 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1745 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1746 if (strchr("LU", *s) &&
1747 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1749 PL_lex_casestack[--PL_lex_casemods] = '\0';
1752 if (PL_lex_casemods > 10) {
1753 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1754 if (newlb != PL_lex_casestack) {
1756 PL_lex_casestack = newlb;
1759 PL_lex_casestack[PL_lex_casemods++] = *s;
1760 PL_lex_casestack[PL_lex_casemods] = '\0';
1761 PL_lex_state = LEX_INTERPCONCAT;
1762 PL_nextval[PL_nexttoke].ival = 0;
1765 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1767 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1769 PL_nextval[PL_nexttoke].ival = OP_LC;
1771 PL_nextval[PL_nexttoke].ival = OP_UC;
1773 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1775 croak("panic: yylex");
1778 if (PL_lex_starts) {
1784 return yylex(PERL_YYLEX_PARAM);
1787 case LEX_INTERPPUSH:
1788 return sublex_push();
1790 case LEX_INTERPSTART:
1791 if (PL_bufptr == PL_bufend)
1792 return sublex_done();
1794 PL_lex_dojoin = (*PL_bufptr == '@');
1795 PL_lex_state = LEX_INTERPNORMAL;
1796 if (PL_lex_dojoin) {
1797 PL_nextval[PL_nexttoke].ival = 0;
1800 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1801 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1802 force_next(PRIVATEREF);
1804 force_ident("\"", '$');
1805 #endif /* USE_THREADS */
1806 PL_nextval[PL_nexttoke].ival = 0;
1808 PL_nextval[PL_nexttoke].ival = 0;
1810 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1813 if (PL_lex_starts++) {
1817 return yylex(PERL_YYLEX_PARAM);
1819 case LEX_INTERPENDMAYBE:
1820 if (intuit_more(PL_bufptr)) {
1821 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1827 if (PL_lex_dojoin) {
1828 PL_lex_dojoin = FALSE;
1829 PL_lex_state = LEX_INTERPCONCAT;
1833 case LEX_INTERPCONCAT:
1835 if (PL_lex_brackets)
1836 croak("panic: INTERPCONCAT");
1838 if (PL_bufptr == PL_bufend)
1839 return sublex_done();
1841 if (SvIVX(PL_linestr) == '\'') {
1842 SV *sv = newSVsv(PL_linestr);
1845 else if ( PL_hints & HINT_NEW_RE )
1846 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1847 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1851 s = scan_const(PL_bufptr);
1853 PL_lex_state = LEX_INTERPCASEMOD;
1855 PL_lex_state = LEX_INTERPSTART;
1858 if (s != PL_bufptr) {
1859 PL_nextval[PL_nexttoke] = yylval;
1862 if (PL_lex_starts++)
1866 return yylex(PERL_YYLEX_PARAM);
1870 return yylex(PERL_YYLEX_PARAM);
1872 PL_lex_state = LEX_NORMAL;
1873 s = scan_formline(PL_bufptr);
1874 if (!PL_lex_formbrack)
1880 PL_oldoldbufptr = PL_oldbufptr;
1883 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1889 if (isIDFIRST_lazy(s))
1891 croak("Unrecognized character \\x%02X", *s & 255);
1894 goto fake_eof; /* emulate EOF on ^D or ^Z */
1899 if (PL_lex_brackets)
1900 yyerror("Missing right bracket");
1903 if (s++ < PL_bufend)
1904 goto retry; /* ignore stray nulls */
1907 if (!PL_in_eval && !PL_preambled) {
1908 PL_preambled = TRUE;
1909 sv_setpv(PL_linestr,incl_perldb());
1910 if (SvCUR(PL_linestr))
1911 sv_catpv(PL_linestr,";");
1913 while(AvFILLp(PL_preambleav) >= 0) {
1914 SV *tmpsv = av_shift(PL_preambleav);
1915 sv_catsv(PL_linestr, tmpsv);
1916 sv_catpv(PL_linestr, ";");
1919 sv_free((SV*)PL_preambleav);
1920 PL_preambleav = NULL;
1922 if (PL_minus_n || PL_minus_p) {
1923 sv_catpv(PL_linestr, "LINE: while (<>) {");
1925 sv_catpv(PL_linestr,"chomp;");
1927 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1929 GvIMPORTED_AV_on(gv);
1931 if (strchr("/'\"", *PL_splitstr)
1932 && strchr(PL_splitstr + 1, *PL_splitstr))
1933 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1936 s = "'~#\200\1'"; /* surely one char is unused...*/
1937 while (s[1] && strchr(PL_splitstr, *s)) s++;
1939 sv_catpvf(PL_linestr, "@F=split(%s%c",
1940 "q" + (delim == '\''), delim);
1941 for (s = PL_splitstr; *s; s++) {
1943 sv_catpvn(PL_linestr, "\\", 1);
1944 sv_catpvn(PL_linestr, s, 1);
1946 sv_catpvf(PL_linestr, "%c);", delim);
1950 sv_catpv(PL_linestr,"@F=split(' ');");
1953 sv_catpv(PL_linestr, "\n");
1954 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1955 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1956 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1957 SV *sv = NEWSV(85,0);
1959 sv_upgrade(sv, SVt_PVMG);
1960 sv_setsv(sv,PL_linestr);
1961 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1966 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1969 if (PL_preprocess && !PL_in_eval)
1970 (void)PerlProc_pclose(PL_rsfp);
1971 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1972 PerlIO_clearerr(PL_rsfp);
1974 (void)PerlIO_close(PL_rsfp);
1976 PL_doextract = FALSE;
1978 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1979 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1980 sv_catpv(PL_linestr,";}");
1981 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1982 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1983 PL_minus_n = PL_minus_p = 0;
1986 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1987 sv_setpv(PL_linestr,"");
1988 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1991 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1992 PL_doextract = FALSE;
1994 /* Incest with pod. */
1995 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1996 sv_setpv(PL_linestr, "");
1997 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1998 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1999 PL_doextract = FALSE;
2003 } while (PL_doextract);
2004 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2005 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2006 SV *sv = NEWSV(85,0);
2008 sv_upgrade(sv, SVt_PVMG);
2009 sv_setsv(sv,PL_linestr);
2010 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2012 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2013 if (PL_curcop->cop_line == 1) {
2014 while (s < PL_bufend && isSPACE(*s))
2016 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2020 if (*s == '#' && *(s+1) == '!')
2022 #ifdef ALTERNATE_SHEBANG
2024 static char as[] = ALTERNATE_SHEBANG;
2025 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2026 d = s + (sizeof(as) - 1);
2028 #endif /* ALTERNATE_SHEBANG */
2037 while (*d && !isSPACE(*d))
2041 #ifdef ARG_ZERO_IS_SCRIPT
2042 if (ipathend > ipath) {
2044 * HP-UX (at least) sets argv[0] to the script name,
2045 * which makes $^X incorrect. And Digital UNIX and Linux,
2046 * at least, set argv[0] to the basename of the Perl
2047 * interpreter. So, having found "#!", we'll set it right.
2049 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2050 assert(SvPOK(x) || SvGMAGICAL(x));
2051 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2052 sv_setpvn(x, ipath, ipathend - ipath);
2055 TAINT_NOT; /* $^X is always tainted, but that's OK */
2057 #endif /* ARG_ZERO_IS_SCRIPT */
2062 d = instr(s,"perl -");
2064 d = instr(s,"perl");
2065 #ifdef ALTERNATE_SHEBANG
2067 * If the ALTERNATE_SHEBANG on this system starts with a
2068 * character that can be part of a Perl expression, then if
2069 * we see it but not "perl", we're probably looking at the
2070 * start of Perl code, not a request to hand off to some
2071 * other interpreter. Similarly, if "perl" is there, but
2072 * not in the first 'word' of the line, we assume the line
2073 * contains the start of the Perl program.
2075 if (d && *s != '#') {
2077 while (*c && !strchr("; \t\r\n\f\v#", *c))
2080 d = Nullch; /* "perl" not in first word; ignore */
2082 *s = '#'; /* Don't try to parse shebang line */
2084 #endif /* ALTERNATE_SHEBANG */
2089 !instr(s,"indir") &&
2090 instr(PL_origargv[0],"perl"))
2096 while (s < PL_bufend && isSPACE(*s))
2098 if (s < PL_bufend) {
2099 Newz(899,newargv,PL_origargc+3,char*);
2101 while (s < PL_bufend && !isSPACE(*s))
2104 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2107 newargv = PL_origargv;
2109 execv(ipath, newargv);
2110 croak("Can't exec %s", ipath);
2113 U32 oldpdb = PL_perldb;
2114 bool oldn = PL_minus_n;
2115 bool oldp = PL_minus_p;
2117 while (*d && !isSPACE(*d)) d++;
2118 while (*d == ' ' || *d == '\t') d++;
2122 if (*d == 'M' || *d == 'm') {
2124 while (*d && !isSPACE(*d)) d++;
2125 croak("Too late for \"-%.*s\" option",
2128 d = moreswitches(d);
2130 if (PERLDB_LINE && !oldpdb ||
2131 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2132 /* if we have already added "LINE: while (<>) {",
2133 we must not do it again */
2135 sv_setpv(PL_linestr, "");
2136 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2137 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2138 PL_preambled = FALSE;
2140 (void)gv_fetchfile(PL_origfilename);
2147 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2149 PL_lex_state = LEX_FORMLINE;
2150 return yylex(PERL_YYLEX_PARAM);
2154 #ifdef PERL_STRICT_CR
2155 warn("Illegal character \\%03o (carriage return)", '\r');
2157 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2159 case ' ': case '\t': case '\f': case 013:
2164 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2166 while (s < d && *s != '\n')
2171 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2173 PL_lex_state = LEX_FORMLINE;
2174 return yylex(PERL_YYLEX_PARAM);
2183 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2188 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2191 if (strnEQ(s,"=>",2)) {
2192 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2193 OPERATOR('-'); /* unary minus */
2195 PL_last_uni = PL_oldbufptr;
2196 PL_last_lop_op = OP_FTEREAD; /* good enough */
2198 case 'r': FTST(OP_FTEREAD);
2199 case 'w': FTST(OP_FTEWRITE);
2200 case 'x': FTST(OP_FTEEXEC);
2201 case 'o': FTST(OP_FTEOWNED);
2202 case 'R': FTST(OP_FTRREAD);
2203 case 'W': FTST(OP_FTRWRITE);
2204 case 'X': FTST(OP_FTREXEC);
2205 case 'O': FTST(OP_FTROWNED);
2206 case 'e': FTST(OP_FTIS);
2207 case 'z': FTST(OP_FTZERO);
2208 case 's': FTST(OP_FTSIZE);
2209 case 'f': FTST(OP_FTFILE);
2210 case 'd': FTST(OP_FTDIR);
2211 case 'l': FTST(OP_FTLINK);
2212 case 'p': FTST(OP_FTPIPE);
2213 case 'S': FTST(OP_FTSOCK);
2214 case 'u': FTST(OP_FTSUID);
2215 case 'g': FTST(OP_FTSGID);
2216 case 'k': FTST(OP_FTSVTX);
2217 case 'b': FTST(OP_FTBLK);
2218 case 'c': FTST(OP_FTCHR);
2219 case 't': FTST(OP_FTTTY);
2220 case 'T': FTST(OP_FTTEXT);
2221 case 'B': FTST(OP_FTBINARY);
2222 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2223 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2224 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2226 croak("Unrecognized file test: -%c", (int)tmp);
2233 if (PL_expect == XOPERATOR)
2238 else if (*s == '>') {
2241 if (isIDFIRST_lazy(s)) {
2242 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2250 if (PL_expect == XOPERATOR)
2253 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2255 OPERATOR('-'); /* unary minus */
2262 if (PL_expect == XOPERATOR)
2267 if (PL_expect == XOPERATOR)
2270 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2276 if (PL_expect != XOPERATOR) {
2277 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2278 PL_expect = XOPERATOR;
2279 force_ident(PL_tokenbuf, '*');
2292 if (PL_expect == XOPERATOR) {
2296 PL_tokenbuf[0] = '%';
2297 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2298 if (!PL_tokenbuf[1]) {
2300 yyerror("Final % should be \\% or %name");
2303 PL_pending_ident = '%';
2325 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2326 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2331 if (PL_curcop->cop_line < PL_copline)
2332 PL_copline = PL_curcop->cop_line;
2343 if (PL_lex_brackets <= 0)
2344 yyerror("Unmatched right bracket");
2347 if (PL_lex_state == LEX_INTERPNORMAL) {
2348 if (PL_lex_brackets == 0) {
2349 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2350 PL_lex_state = LEX_INTERPEND;
2357 if (PL_lex_brackets > 100) {
2358 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2359 if (newlb != PL_lex_brackstack) {
2361 PL_lex_brackstack = newlb;
2364 switch (PL_expect) {
2366 if (PL_lex_formbrack) {
2370 if (PL_oldoldbufptr == PL_last_lop)
2371 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2373 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2374 OPERATOR(HASHBRACK);
2376 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2379 PL_tokenbuf[0] = '\0';
2380 if (d < PL_bufend && *d == '-') {
2381 PL_tokenbuf[0] = '-';
2383 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2386 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2387 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2389 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2392 char minus = (PL_tokenbuf[0] == '-');
2393 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2400 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2404 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2409 if (PL_oldoldbufptr == PL_last_lop)
2410 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2412 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2415 OPERATOR(HASHBRACK);
2416 /* This hack serves to disambiguate a pair of curlies
2417 * as being a block or an anon hash. Normally, expectation
2418 * determines that, but in cases where we're not in a
2419 * position to expect anything in particular (like inside
2420 * eval"") we have to resolve the ambiguity. This code
2421 * covers the case where the first term in the curlies is a
2422 * quoted string. Most other cases need to be explicitly
2423 * disambiguated by prepending a `+' before the opening
2424 * curly in order to force resolution as an anon hash.
2426 * XXX should probably propagate the outer expectation
2427 * into eval"" to rely less on this hack, but that could
2428 * potentially break current behavior of eval"".
2432 if (*s == '\'' || *s == '"' || *s == '`') {
2433 /* common case: get past first string, handling escapes */
2434 for (t++; t < PL_bufend && *t != *s;)
2435 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2439 else if (*s == 'q') {
2442 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2443 && !isALNUM(*t)))) {
2445 char open, close, term;
2448 while (t < PL_bufend && isSPACE(*t))
2452 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2456 for (t++; t < PL_bufend; t++) {
2457 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2459 else if (*t == open)
2463 for (t++; t < PL_bufend; t++) {
2464 if (*t == '\\' && t+1 < PL_bufend)
2466 else if (*t == close && --brackets <= 0)
2468 else if (*t == open)
2474 else if (isIDFIRST_lazy(s)) {
2475 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2477 while (t < PL_bufend && isSPACE(*t))
2479 /* if comma follows first term, call it an anon hash */
2480 /* XXX it could be a comma expression with loop modifiers */
2481 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2482 || (*t == '=' && t[1] == '>')))
2483 OPERATOR(HASHBRACK);
2484 if (PL_expect == XREF)
2485 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2487 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2493 yylval.ival = PL_curcop->cop_line;
2494 if (isSPACE(*s) || *s == '#')
2495 PL_copline = NOLINE; /* invalidate current command line number */
2500 if (PL_lex_brackets <= 0)
2501 yyerror("Unmatched right bracket");
2503 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2504 if (PL_lex_brackets < PL_lex_formbrack)
2505 PL_lex_formbrack = 0;
2506 if (PL_lex_state == LEX_INTERPNORMAL) {
2507 if (PL_lex_brackets == 0) {
2508 if (PL_lex_fakebrack) {
2509 PL_lex_state = LEX_INTERPEND;
2511 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2513 if (*s == '-' && s[1] == '>')
2514 PL_lex_state = LEX_INTERPENDMAYBE;
2515 else if (*s != '[' && *s != '{')
2516 PL_lex_state = LEX_INTERPEND;
2519 if (PL_lex_brackets < PL_lex_fakebrack) {
2521 PL_lex_fakebrack = 0;
2522 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2532 if (PL_expect == XOPERATOR) {
2533 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2534 PL_curcop->cop_line--;
2535 warner(WARN_SEMICOLON, warn_nosemi);
2536 PL_curcop->cop_line++;
2541 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2543 PL_expect = XOPERATOR;
2544 force_ident(PL_tokenbuf, '&');
2548 yylval.ival = (OPpENTERSUB_AMPER<<8);
2567 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2568 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2570 if (PL_expect == XSTATE && isALPHA(tmp) &&
2571 (s == PL_linestart+1 || s[-2] == '\n') )
2573 if (PL_in_eval && !PL_rsfp) {
2578 if (strnEQ(s,"=cut",4)) {
2592 PL_doextract = TRUE;
2595 if (PL_lex_brackets < PL_lex_formbrack) {
2597 #ifdef PERL_STRICT_CR
2598 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2600 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2602 if (*t == '\n' || *t == '#') {
2620 if (PL_expect != XOPERATOR) {
2621 if (s[1] != '<' && !strchr(s,'>'))
2624 s = scan_heredoc(s);
2626 s = scan_inputsymbol(s);
2627 TERM(sublex_start());
2632 SHop(OP_LEFT_SHIFT);
2646 SHop(OP_RIGHT_SHIFT);
2655 if (PL_expect == XOPERATOR) {
2656 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2659 return ','; /* grandfather non-comma-format format */
2663 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2664 if (PL_expect == XOPERATOR)
2665 no_op("Array length", PL_bufptr);
2666 PL_tokenbuf[0] = '@';
2667 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2669 if (!PL_tokenbuf[1])
2671 PL_expect = XOPERATOR;
2672 PL_pending_ident = '#';
2676 if (PL_expect == XOPERATOR)
2677 no_op("Scalar", PL_bufptr);
2678 PL_tokenbuf[0] = '$';
2679 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2680 if (!PL_tokenbuf[1]) {
2682 yyerror("Final $ should be \\$ or $name");
2686 /* This kludge not intended to be bulletproof. */
2687 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2688 yylval.opval = newSVOP(OP_CONST, 0,
2689 newSViv((IV)PL_compiling.cop_arybase));
2690 yylval.opval->op_private = OPpCONST_ARYBASE;
2695 if (PL_lex_state == LEX_NORMAL)
2698 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2701 PL_tokenbuf[0] = '@';
2702 if (ckWARN(WARN_SYNTAX)) {
2704 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2707 PL_bufptr = skipspace(PL_bufptr);
2708 while (t < PL_bufend && *t != ']')
2711 "Multidimensional syntax %.*s not supported",
2712 (t - PL_bufptr) + 1, PL_bufptr);
2716 else if (*s == '{') {
2717 PL_tokenbuf[0] = '%';
2718 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2719 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2721 char tmpbuf[sizeof PL_tokenbuf];
2723 for (t++; isSPACE(*t); t++) ;
2724 if (isIDFIRST_lazy(t)) {
2725 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2726 for (; isSPACE(*t); t++) ;
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_lazy(s+1))
2743 PL_expect = XTERM; /* e.g. print $fh &sub */
2744 else if (isIDFIRST_lazy(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]) && s[1] != '=')
2775 PL_expect = XTERM; /* e.g. print $fh -1 */
2776 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && 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_lazy(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_lazy(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 ((isIDFIRST_lazy(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)) {
3158 if ((cv = GvCV(gv)) && SvPOK(cv))
3159 PL_last_proto = SvPV((SV*)cv, PL_na);
3160 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3161 if (*d == ')' && (sv = cv_const_sv(cv))) {
3166 PL_nextval[PL_nexttoke].opval = yylval.opval;
3167 PL_expect = XOPERATOR;
3170 PL_last_lop_op = OP_ENTERSUB;
3174 /* If followed by var or block, call it a method (unless sub) */
3176 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3177 PL_last_lop = PL_oldbufptr;
3178 PL_last_lop_op = OP_METHOD;
3182 /* If followed by a bareword, see if it looks like indir obj. */
3184 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3187 /* Not a method, so call it a subroutine (if defined) */
3189 if (gv && GvCVu(gv)) {
3191 if (lastchar == '-')
3192 warn("Ambiguous use of -%s resolved as -&%s()",
3193 PL_tokenbuf, PL_tokenbuf);
3194 PL_last_lop = PL_oldbufptr;
3195 PL_last_lop_op = OP_ENTERSUB;
3196 /* Check for a constant sub */
3198 if ((sv = cv_const_sv(cv))) {
3200 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3201 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3202 yylval.opval->op_private = 0;
3206 /* Resolve to GV now. */
3207 op_free(yylval.opval);
3208 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3209 PL_last_lop_op = OP_ENTERSUB;
3210 /* Is there a prototype? */
3213 PL_last_proto = SvPV((SV*)cv, len);
3216 if (strEQ(PL_last_proto, "$"))
3218 if (*PL_last_proto == '&' && *s == '{') {
3219 sv_setpv(PL_subname,"__ANON__");
3223 PL_last_proto = NULL;
3224 PL_nextval[PL_nexttoke].opval = yylval.opval;
3230 if (PL_hints & HINT_STRICT_SUBS &&
3233 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3234 PL_last_lop_op != OP_ACCEPT &&
3235 PL_last_lop_op != OP_PIPE_OP &&
3236 PL_last_lop_op != OP_SOCKPAIR &&
3237 !(PL_last_lop_op == OP_ENTERSUB
3239 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3242 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3247 /* Call it a bare word */
3250 if (ckWARN(WARN_RESERVED)) {
3251 if (lastchar != '-') {
3252 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3254 warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
3259 if (lastchar && strchr("*%&", lastchar)) {
3260 warn("Operator or semicolon missing before %c%s",
3261 lastchar, PL_tokenbuf);
3262 warn("Ambiguous use of %c resolved as operator %c",
3263 lastchar, lastchar);
3269 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3270 newSVsv(GvSV(PL_curcop->cop_filegv)));
3274 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3275 newSVpvf("%ld", (long)PL_curcop->cop_line));
3278 case KEY___PACKAGE__:
3279 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3281 ? newSVsv(PL_curstname)
3290 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3291 char *pname = "main";
3292 if (PL_tokenbuf[2] == 'D')
3293 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3294 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3297 GvIOp(gv) = newIO();
3298 IoIFP(GvIOp(gv)) = PL_rsfp;
3299 #if defined(HAS_FCNTL) && defined(F_SETFD)
3301 int fd = PerlIO_fileno(PL_rsfp);
3302 fcntl(fd,F_SETFD,fd >= 3);
3305 /* Mark this internal pseudo-handle as clean */
3306 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3308 IoTYPE(GvIOp(gv)) = '|';
3309 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3310 IoTYPE(GvIOp(gv)) = '-';
3312 IoTYPE(GvIOp(gv)) = '<';
3323 if (PL_expect == XSTATE) {
3330 if (*s == ':' && s[1] == ':') {
3333 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3334 tmp = keyword(PL_tokenbuf, len);
3348 LOP(OP_ACCEPT,XTERM);
3354 LOP(OP_ATAN2,XTERM);
3363 LOP(OP_BLESS,XTERM);
3372 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3389 if (!PL_cryptseen++)
3392 LOP(OP_CRYPT,XTERM);
3395 if (ckWARN(WARN_OCTAL)) {
3396 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3397 if (*d != '0' && isDIGIT(*d))
3398 yywarn("chmod: mode argument is missing initial 0");
3400 LOP(OP_CHMOD,XTERM);
3403 LOP(OP_CHOWN,XTERM);
3406 LOP(OP_CONNECT,XTERM);
3422 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3426 PL_hints |= HINT_BLOCK_SCOPE;
3436 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3437 LOP(OP_DBMOPEN,XTERM);
3443 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3450 yylval.ival = PL_curcop->cop_line;
3464 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3465 UNIBRACK(OP_ENTEREVAL);
3480 case KEY_endhostent:
3486 case KEY_endservent:
3489 case KEY_endprotoent:
3500 yylval.ival = PL_curcop->cop_line;
3502 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3504 if ((PL_bufend - p) >= 3 &&
3505 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3508 if (isIDFIRST_lazy(p))
3509 croak("Missing $ on loop variable");
3514 LOP(OP_FORMLINE,XTERM);
3520 LOP(OP_FCNTL,XTERM);
3526 LOP(OP_FLOCK,XTERM);
3535 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3538 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3553 case KEY_getpriority:
3554 LOP(OP_GETPRIORITY,XTERM);
3556 case KEY_getprotobyname:
3559 case KEY_getprotobynumber:
3560 LOP(OP_GPBYNUMBER,XTERM);
3562 case KEY_getprotoent:
3574 case KEY_getpeername:
3575 UNI(OP_GETPEERNAME);
3577 case KEY_gethostbyname:
3580 case KEY_gethostbyaddr:
3581 LOP(OP_GHBYADDR,XTERM);
3583 case KEY_gethostent:
3586 case KEY_getnetbyname:
3589 case KEY_getnetbyaddr:
3590 LOP(OP_GNBYADDR,XTERM);
3595 case KEY_getservbyname:
3596 LOP(OP_GSBYNAME,XTERM);
3598 case KEY_getservbyport:
3599 LOP(OP_GSBYPORT,XTERM);
3601 case KEY_getservent:
3604 case KEY_getsockname:
3605 UNI(OP_GETSOCKNAME);
3607 case KEY_getsockopt:
3608 LOP(OP_GSOCKOPT,XTERM);
3630 yylval.ival = PL_curcop->cop_line;
3634 LOP(OP_INDEX,XTERM);
3640 LOP(OP_IOCTL,XTERM);
3652 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3683 LOP(OP_LISTEN,XTERM);
3692 s = scan_pat(s,OP_MATCH);
3693 TERM(sublex_start());
3696 LOP(OP_MAPSTART, XREF);
3699 LOP(OP_MKDIR,XTERM);
3702 LOP(OP_MSGCTL,XTERM);
3705 LOP(OP_MSGGET,XTERM);
3708 LOP(OP_MSGRCV,XTERM);
3711 LOP(OP_MSGSND,XTERM);
3716 if (isIDFIRST_lazy(s)) {
3717 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3718 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3719 if (!PL_in_my_stash) {
3722 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3729 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3736 if (PL_expect != XSTATE)
3737 yyerror("\"no\" not allowed in expression");
3738 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3739 s = force_version(s);
3748 if (isIDFIRST_lazy(s)) {
3750 for (d = s; isALNUM_lazy(d); d++) ;
3752 if (strchr("|&*+-=!?:.", *t))
3753 warn("Precedence problem: open %.*s should be open(%.*s)",
3759 yylval.ival = OP_OR;
3769 LOP(OP_OPEN_DIR,XTERM);
3772 checkcomma(s,PL_tokenbuf,"filehandle");
3776 checkcomma(s,PL_tokenbuf,"filehandle");
3795 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3799 LOP(OP_PIPE_OP,XTERM);
3804 missingterm((char*)0);
3805 yylval.ival = OP_CONST;
3806 TERM(sublex_start());
3814 missingterm((char*)0);
3815 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3816 d = SvPV_force(PL_lex_stuff, len);
3817 for (; len; --len, ++d) {
3820 "Possible attempt to separate words with commas");
3825 "Possible attempt to put comments in qw() list");
3831 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3832 PL_lex_stuff = Nullsv;
3835 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3838 yylval.ival = OP_SPLIT;
3842 PL_last_lop = PL_oldbufptr;
3843 PL_last_lop_op = OP_SPLIT;
3849 missingterm((char*)0);
3850 yylval.ival = OP_STRINGIFY;
3851 if (SvIVX(PL_lex_stuff) == '\'')
3852 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3853 TERM(sublex_start());
3856 s = scan_pat(s,OP_QR);
3857 TERM(sublex_start());
3862 missingterm((char*)0);
3863 yylval.ival = OP_BACKTICK;
3865 TERM(sublex_start());
3871 *PL_tokenbuf = '\0';
3872 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3873 if (isIDFIRST_lazy(PL_tokenbuf))
3874 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3876 yyerror("<> should be quotes");
3883 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3887 LOP(OP_RENAME,XTERM);
3896 LOP(OP_RINDEX,XTERM);
3919 LOP(OP_REVERSE,XTERM);
3930 TERM(sublex_start());
3932 TOKEN(1); /* force error */
3941 LOP(OP_SELECT,XTERM);
3947 LOP(OP_SEMCTL,XTERM);
3950 LOP(OP_SEMGET,XTERM);
3953 LOP(OP_SEMOP,XTERM);
3959 LOP(OP_SETPGRP,XTERM);
3961 case KEY_setpriority:
3962 LOP(OP_SETPRIORITY,XTERM);
3964 case KEY_sethostent:
3970 case KEY_setservent:
3973 case KEY_setprotoent:
3983 LOP(OP_SEEKDIR,XTERM);
3985 case KEY_setsockopt:
3986 LOP(OP_SSOCKOPT,XTERM);
3992 LOP(OP_SHMCTL,XTERM);
3995 LOP(OP_SHMGET,XTERM);
3998 LOP(OP_SHMREAD,XTERM);
4001 LOP(OP_SHMWRITE,XTERM);
4004 LOP(OP_SHUTDOWN,XTERM);
4013 LOP(OP_SOCKET,XTERM);
4015 case KEY_socketpair:
4016 LOP(OP_SOCKPAIR,XTERM);
4019 checkcomma(s,PL_tokenbuf,"subroutine name");
4021 if (*s == ';' || *s == ')') /* probably a close */
4022 croak("sort is now a reserved word");
4024 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4028 LOP(OP_SPLIT,XTERM);
4031 LOP(OP_SPRINTF,XTERM);
4034 LOP(OP_SPLICE,XTERM);
4050 LOP(OP_SUBSTR,XTERM);
4057 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4058 char tmpbuf[sizeof PL_tokenbuf];
4060 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4061 if (strchr(tmpbuf, ':'))
4062 sv_setpv(PL_subname, tmpbuf);
4064 sv_setsv(PL_subname,PL_curstname);
4065 sv_catpvn(PL_subname,"::",2);
4066 sv_catpvn(PL_subname,tmpbuf,len);
4068 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4072 PL_expect = XTERMBLOCK;
4073 sv_setpv(PL_subname,"?");
4076 if (tmp == KEY_format) {
4079 PL_lex_formbrack = PL_lex_brackets + 1;
4083 /* Look for a prototype */
4090 SvREFCNT_dec(PL_lex_stuff);
4091 PL_lex_stuff = Nullsv;
4092 croak("Prototype not terminated");
4095 d = SvPVX(PL_lex_stuff);
4097 for (p = d; *p; ++p) {
4102 SvCUR(PL_lex_stuff) = tmp;
4105 PL_nextval[1] = PL_nextval[0];
4106 PL_nexttype[1] = PL_nexttype[0];
4107 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4108 PL_nexttype[0] = THING;
4109 if (PL_nexttoke == 1) {
4110 PL_lex_defer = PL_lex_state;
4111 PL_lex_expect = PL_expect;
4112 PL_lex_state = LEX_KNOWNEXT;
4114 PL_lex_stuff = Nullsv;
4117 if (*SvPV(PL_subname,PL_na) == '?') {
4118 sv_setpv(PL_subname,"__ANON__");
4125 LOP(OP_SYSTEM,XREF);
4128 LOP(OP_SYMLINK,XTERM);
4131 LOP(OP_SYSCALL,XTERM);
4134 LOP(OP_SYSOPEN,XTERM);
4137 LOP(OP_SYSSEEK,XTERM);
4140 LOP(OP_SYSREAD,XTERM);
4143 LOP(OP_SYSWRITE,XTERM);
4147 TERM(sublex_start());
4168 LOP(OP_TRUNCATE,XTERM);
4180 yylval.ival = PL_curcop->cop_line;
4184 yylval.ival = PL_curcop->cop_line;
4188 LOP(OP_UNLINK,XTERM);
4194 LOP(OP_UNPACK,XTERM);
4197 LOP(OP_UTIME,XTERM);
4200 if (ckWARN(WARN_OCTAL)) {
4201 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4202 if (*d != '0' && isDIGIT(*d))
4203 yywarn("umask: argument is missing initial 0");
4208 LOP(OP_UNSHIFT,XTERM);
4211 if (PL_expect != XSTATE)
4212 yyerror("\"use\" not allowed in expression");
4215 s = force_version(s);
4216 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4217 PL_nextval[PL_nexttoke].opval = Nullop;
4222 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4223 s = force_version(s);
4236 yylval.ival = PL_curcop->cop_line;
4240 PL_hints |= HINT_BLOCK_SCOPE;
4247 LOP(OP_WAITPID,XTERM);
4255 static char ctl_l[2];
4257 if (ctl_l[0] == '\0')
4258 ctl_l[0] = toCTRL('L');
4259 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4262 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4267 if (PL_expect == XOPERATOR)
4273 yylval.ival = OP_XOR;
4278 TERM(sublex_start());
4284 keyword(register char *d, I32 len)
4289 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4290 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4291 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4292 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4293 if (strEQ(d,"__END__")) return KEY___END__;
4297 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4302 if (strEQ(d,"and")) return -KEY_and;
4303 if (strEQ(d,"abs")) return -KEY_abs;
4306 if (strEQ(d,"alarm")) return -KEY_alarm;
4307 if (strEQ(d,"atan2")) return -KEY_atan2;
4310 if (strEQ(d,"accept")) return -KEY_accept;
4315 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4318 if (strEQ(d,"bless")) return -KEY_bless;
4319 if (strEQ(d,"bind")) return -KEY_bind;
4320 if (strEQ(d,"binmode")) return -KEY_binmode;
4323 if (strEQ(d,"CORE")) return -KEY_CORE;
4328 if (strEQ(d,"cmp")) return -KEY_cmp;
4329 if (strEQ(d,"chr")) return -KEY_chr;
4330 if (strEQ(d,"cos")) return -KEY_cos;
4333 if (strEQ(d,"chop")) return KEY_chop;
4336 if (strEQ(d,"close")) return -KEY_close;
4337 if (strEQ(d,"chdir")) return -KEY_chdir;
4338 if (strEQ(d,"chomp")) return KEY_chomp;
4339 if (strEQ(d,"chmod")) return -KEY_chmod;
4340 if (strEQ(d,"chown")) return -KEY_chown;
4341 if (strEQ(d,"crypt")) return -KEY_crypt;
4344 if (strEQ(d,"chroot")) return -KEY_chroot;
4345 if (strEQ(d,"caller")) return -KEY_caller;
4348 if (strEQ(d,"connect")) return -KEY_connect;
4351 if (strEQ(d,"closedir")) return -KEY_closedir;
4352 if (strEQ(d,"continue")) return -KEY_continue;
4357 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4362 if (strEQ(d,"do")) return KEY_do;
4365 if (strEQ(d,"die")) return -KEY_die;
4368 if (strEQ(d,"dump")) return -KEY_dump;
4371 if (strEQ(d,"delete")) return KEY_delete;
4374 if (strEQ(d,"defined")) return KEY_defined;
4375 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4378 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4383 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4384 if (strEQ(d,"END")) return KEY_END;
4389 if (strEQ(d,"eq")) return -KEY_eq;
4392 if (strEQ(d,"eof")) return -KEY_eof;
4393 if (strEQ(d,"exp")) return -KEY_exp;
4396 if (strEQ(d,"else")) return KEY_else;
4397 if (strEQ(d,"exit")) return -KEY_exit;
4398 if (strEQ(d,"eval")) return KEY_eval;
4399 if (strEQ(d,"exec")) return -KEY_exec;
4400 if (strEQ(d,"each")) return KEY_each;
4403 if (strEQ(d,"elsif")) return KEY_elsif;
4406 if (strEQ(d,"exists")) return KEY_exists;
4407 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4410 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4411 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4414 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4417 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4418 if (strEQ(d,"endservent")) return -KEY_endservent;
4421 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4428 if (strEQ(d,"for")) return KEY_for;
4431 if (strEQ(d,"fork")) return -KEY_fork;
4434 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4435 if (strEQ(d,"flock")) return -KEY_flock;
4438 if (strEQ(d,"format")) return KEY_format;
4439 if (strEQ(d,"fileno")) return -KEY_fileno;
4442 if (strEQ(d,"foreach")) return KEY_foreach;
4445 if (strEQ(d,"formline")) return -KEY_formline;
4451 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4452 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4456 if (strnEQ(d,"get",3)) {
4461 if (strEQ(d,"ppid")) return -KEY_getppid;
4462 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4465 if (strEQ(d,"pwent")) return -KEY_getpwent;
4466 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4467 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4470 if (strEQ(d,"peername")) return -KEY_getpeername;
4471 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4472 if (strEQ(d,"priority")) return -KEY_getpriority;
4475 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4478 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4482 else if (*d == 'h') {
4483 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4484 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4485 if (strEQ(d,"hostent")) return -KEY_gethostent;
4487 else if (*d == 'n') {
4488 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4489 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4490 if (strEQ(d,"netent")) return -KEY_getnetent;
4492 else if (*d == 's') {
4493 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4494 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4495 if (strEQ(d,"servent")) return -KEY_getservent;
4496 if (strEQ(d,"sockname")) return -KEY_getsockname;
4497 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4499 else if (*d == 'g') {
4500 if (strEQ(d,"grent")) return -KEY_getgrent;
4501 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4502 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4504 else if (*d == 'l') {
4505 if (strEQ(d,"login")) return -KEY_getlogin;
4507 else if (strEQ(d,"c")) return -KEY_getc;
4512 if (strEQ(d,"gt")) return -KEY_gt;
4513 if (strEQ(d,"ge")) return -KEY_ge;
4516 if (strEQ(d,"grep")) return KEY_grep;
4517 if (strEQ(d,"goto")) return KEY_goto;
4518 if (strEQ(d,"glob")) return KEY_glob;
4521 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4526 if (strEQ(d,"hex")) return -KEY_hex;
4529 if (strEQ(d,"INIT")) return KEY_INIT;
4534 if (strEQ(d,"if")) return KEY_if;
4537 if (strEQ(d,"int")) return -KEY_int;
4540 if (strEQ(d,"index")) return -KEY_index;
4541 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4546 if (strEQ(d,"join")) return -KEY_join;
4550 if (strEQ(d,"keys")) return KEY_keys;
4551 if (strEQ(d,"kill")) return -KEY_kill;
4556 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4557 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4563 if (strEQ(d,"lt")) return -KEY_lt;
4564 if (strEQ(d,"le")) return -KEY_le;
4565 if (strEQ(d,"lc")) return -KEY_lc;
4568 if (strEQ(d,"log")) return -KEY_log;
4571 if (strEQ(d,"last")) return KEY_last;
4572 if (strEQ(d,"link")) return -KEY_link;
4573 if (strEQ(d,"lock")) return -KEY_lock;
4576 if (strEQ(d,"local")) return KEY_local;
4577 if (strEQ(d,"lstat")) return -KEY_lstat;
4580 if (strEQ(d,"length")) return -KEY_length;
4581 if (strEQ(d,"listen")) return -KEY_listen;
4584 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4587 if (strEQ(d,"localtime")) return -KEY_localtime;
4593 case 1: return KEY_m;
4595 if (strEQ(d,"my")) return KEY_my;
4598 if (strEQ(d,"map")) return KEY_map;
4601 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4604 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4605 if (strEQ(d,"msgget")) return -KEY_msgget;
4606 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4607 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4612 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4615 if (strEQ(d,"next")) return KEY_next;
4616 if (strEQ(d,"ne")) return -KEY_ne;
4617 if (strEQ(d,"not")) return -KEY_not;
4618 if (strEQ(d,"no")) return KEY_no;
4623 if (strEQ(d,"or")) return -KEY_or;
4626 if (strEQ(d,"ord")) return -KEY_ord;
4627 if (strEQ(d,"oct")) return -KEY_oct;
4628 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4632 if (strEQ(d,"open")) return -KEY_open;
4635 if (strEQ(d,"opendir")) return -KEY_opendir;
4642 if (strEQ(d,"pop")) return KEY_pop;
4643 if (strEQ(d,"pos")) return KEY_pos;
4646 if (strEQ(d,"push")) return KEY_push;
4647 if (strEQ(d,"pack")) return -KEY_pack;
4648 if (strEQ(d,"pipe")) return -KEY_pipe;
4651 if (strEQ(d,"print")) return KEY_print;
4654 if (strEQ(d,"printf")) return KEY_printf;
4657 if (strEQ(d,"package")) return KEY_package;
4660 if (strEQ(d,"prototype")) return KEY_prototype;
4665 if (strEQ(d,"q")) return KEY_q;
4666 if (strEQ(d,"qr")) return KEY_qr;
4667 if (strEQ(d,"qq")) return KEY_qq;
4668 if (strEQ(d,"qw")) return KEY_qw;
4669 if (strEQ(d,"qx")) return KEY_qx;
4671 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4676 if (strEQ(d,"ref")) return -KEY_ref;
4679 if (strEQ(d,"read")) return -KEY_read;
4680 if (strEQ(d,"rand")) return -KEY_rand;
4681 if (strEQ(d,"recv")) return -KEY_recv;
4682 if (strEQ(d,"redo")) return KEY_redo;
4685 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4686 if (strEQ(d,"reset")) return -KEY_reset;
4689 if (strEQ(d,"return")) return KEY_return;
4690 if (strEQ(d,"rename")) return -KEY_rename;
4691 if (strEQ(d,"rindex")) return -KEY_rindex;
4694 if (strEQ(d,"require")) return -KEY_require;
4695 if (strEQ(d,"reverse")) return -KEY_reverse;
4696 if (strEQ(d,"readdir")) return -KEY_readdir;
4699 if (strEQ(d,"readlink")) return -KEY_readlink;
4700 if (strEQ(d,"readline")) return -KEY_readline;
4701 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4704 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4710 case 0: return KEY_s;
4712 if (strEQ(d,"scalar")) return KEY_scalar;
4717 if (strEQ(d,"seek")) return -KEY_seek;
4718 if (strEQ(d,"send")) return -KEY_send;
4721 if (strEQ(d,"semop")) return -KEY_semop;
4724 if (strEQ(d,"select")) return -KEY_select;
4725 if (strEQ(d,"semctl")) return -KEY_semctl;
4726 if (strEQ(d,"semget")) return -KEY_semget;
4729 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4730 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4733 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4734 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4737 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4740 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4741 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4742 if (strEQ(d,"setservent")) return -KEY_setservent;
4745 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4746 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4753 if (strEQ(d,"shift")) return KEY_shift;
4756 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4757 if (strEQ(d,"shmget")) return -KEY_shmget;
4760 if (strEQ(d,"shmread")) return -KEY_shmread;
4763 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4764 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4769 if (strEQ(d,"sin")) return -KEY_sin;
4772 if (strEQ(d,"sleep")) return -KEY_sleep;
4775 if (strEQ(d,"sort")) return KEY_sort;
4776 if (strEQ(d,"socket")) return -KEY_socket;
4777 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4780 if (strEQ(d,"split")) return KEY_split;
4781 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4782 if (strEQ(d,"splice")) return KEY_splice;
4785 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4788 if (strEQ(d,"srand")) return -KEY_srand;
4791 if (strEQ(d,"stat")) return -KEY_stat;
4792 if (strEQ(d,"study")) return KEY_study;
4795 if (strEQ(d,"substr")) return -KEY_substr;
4796 if (strEQ(d,"sub")) return KEY_sub;
4801 if (strEQ(d,"system")) return -KEY_system;
4804 if (strEQ(d,"symlink")) return -KEY_symlink;
4805 if (strEQ(d,"syscall")) return -KEY_syscall;
4806 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4807 if (strEQ(d,"sysread")) return -KEY_sysread;
4808 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4811 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4820 if (strEQ(d,"tr")) return KEY_tr;
4823 if (strEQ(d,"tie")) return KEY_tie;
4826 if (strEQ(d,"tell")) return -KEY_tell;
4827 if (strEQ(d,"tied")) return KEY_tied;
4828 if (strEQ(d,"time")) return -KEY_time;
4831 if (strEQ(d,"times")) return -KEY_times;
4834 if (strEQ(d,"telldir")) return -KEY_telldir;
4837 if (strEQ(d,"truncate")) return -KEY_truncate;
4844 if (strEQ(d,"uc")) return -KEY_uc;
4847 if (strEQ(d,"use")) return KEY_use;
4850 if (strEQ(d,"undef")) return KEY_undef;
4851 if (strEQ(d,"until")) return KEY_until;
4852 if (strEQ(d,"untie")) return KEY_untie;
4853 if (strEQ(d,"utime")) return -KEY_utime;
4854 if (strEQ(d,"umask")) return -KEY_umask;
4857 if (strEQ(d,"unless")) return KEY_unless;
4858 if (strEQ(d,"unpack")) return -KEY_unpack;
4859 if (strEQ(d,"unlink")) return -KEY_unlink;
4862 if (strEQ(d,"unshift")) return KEY_unshift;
4863 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4868 if (strEQ(d,"values")) return -KEY_values;
4869 if (strEQ(d,"vec")) return -KEY_vec;
4874 if (strEQ(d,"warn")) return -KEY_warn;
4875 if (strEQ(d,"wait")) return -KEY_wait;
4878 if (strEQ(d,"while")) return KEY_while;
4879 if (strEQ(d,"write")) return -KEY_write;
4882 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4885 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4890 if (len == 1) return -KEY_x;
4891 if (strEQ(d,"xor")) return -KEY_xor;
4894 if (len == 1) return KEY_y;
4903 checkcomma(register char *s, char *name, char *what)
4907 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4908 dTHR; /* only for ckWARN */
4909 if (ckWARN(WARN_SYNTAX)) {
4911 for (w = s+2; *w && level; w++) {
4918 for (; *w && isSPACE(*w); w++) ;
4919 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4920 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4923 while (s < PL_bufend && isSPACE(*s))
4927 while (s < PL_bufend && isSPACE(*s))
4929 if (isIDFIRST_lazy(s)) {
4931 while (isALNUM_lazy(s))
4933 while (s < PL_bufend && isSPACE(*s))
4938 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4942 croak("No comma allowed after %s", what);
4948 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4951 HV *table = GvHV(PL_hintgv); /* ^H */
4954 bool oldcatch = CATCH_GET;
4960 yyerror("%^H is not defined");
4963 cvp = hv_fetch(table, key, strlen(key), FALSE);
4964 if (!cvp || !SvOK(*cvp)) {
4965 sprintf(buf,"$^H{%s} is not defined", key);
4969 sv_2mortal(sv); /* Parent created it permanently */
4972 pv = sv_2mortal(newSVpv(s, len));
4974 typesv = sv_2mortal(newSVpv(type, 0));
4976 typesv = &PL_sv_undef;
4978 Zero(&myop, 1, BINOP);
4979 myop.op_last = (OP *) &myop;
4980 myop.op_next = Nullop;
4981 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4983 PUSHSTACKi(PERLSI_OVERLOAD);
4986 PL_op = (OP *) &myop;
4987 if (PERLDB_SUB && PL_curstash != PL_debstash)
4988 PL_op->op_private |= OPpENTERSUB_DB;
4999 if (PL_op = pp_entersub(ARGS))
5006 CATCH_SET(oldcatch);
5010 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5013 return SvREFCNT_inc(res);
5017 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5019 register char *d = dest;
5020 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5023 croak(ident_too_long);
5024 if (isALNUM(*s)) /* UTF handled below */
5026 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5031 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5035 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5036 char *t = s + UTF8SKIP(s);
5037 while (*t & 0x80 && is_utf8_mark((U8*)t))
5039 if (d + (t - s) > e)
5040 croak(ident_too_long);
5041 Copy(s, d, t - s, char);
5054 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5061 if (PL_lex_brackets == 0)
5062 PL_lex_fakebrack = 0;
5066 e = d + destlen - 3; /* two-character token, ending NUL */
5068 while (isDIGIT(*s)) {
5070 croak(ident_too_long);
5077 croak(ident_too_long);
5078 if (isALNUM(*s)) /* UTF handled below */
5080 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5085 else if (*s == ':' && s[1] == ':') {
5089 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5090 char *t = s + UTF8SKIP(s);
5091 while (*t & 0x80 && is_utf8_mark((U8*)t))
5093 if (d + (t - s) > e)
5094 croak(ident_too_long);
5095 Copy(s, d, t - s, char);
5106 if (PL_lex_state != LEX_NORMAL)
5107 PL_lex_state = LEX_INTERPENDMAYBE;
5110 if (*s == '$' && s[1] &&
5111 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5124 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5129 if (isSPACE(s[-1])) {
5132 if (ch != ' ' && ch != '\t') {
5138 if (isIDFIRST_lazy(d)) {
5142 while (e < send && isALNUM_lazy(e) || *e == ':') {
5144 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5147 Copy(s, d, e - s, char);
5152 while (isALNUM(*s) || *s == ':')
5156 while (s < send && (*s == ' ' || *s == '\t')) s++;
5157 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5158 dTHR; /* only for ckWARN */
5159 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5160 char *brack = *s == '[' ? "[...]" : "{...}";
5161 warner(WARN_AMBIGUOUS,
5162 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5163 funny, dest, brack, funny, dest, brack);
5165 PL_lex_fakebrack = PL_lex_brackets+1;
5167 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5173 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5174 PL_lex_state = LEX_INTERPEND;
5177 if (PL_lex_state == LEX_NORMAL) {
5178 dTHR; /* only for ckWARN */
5179 if (ckWARN(WARN_AMBIGUOUS) &&
5180 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5182 warner(WARN_AMBIGUOUS,
5183 "Ambiguous use of %c{%s} resolved to %c%s",
5184 funny, dest, funny, dest);
5189 s = bracket; /* let the parser handle it */
5193 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5194 PL_lex_state = LEX_INTERPEND;
5198 void pmflag(U16 *pmfl, int ch)
5203 *pmfl |= PMf_GLOBAL;
5205 *pmfl |= PMf_CONTINUE;
5209 *pmfl |= PMf_MULTILINE;
5211 *pmfl |= PMf_SINGLELINE;
5213 *pmfl |= PMf_EXTENDED;
5217 scan_pat(char *start, I32 type)
5222 s = scan_str(start);
5225 SvREFCNT_dec(PL_lex_stuff);
5226 PL_lex_stuff = Nullsv;
5227 croak("Search pattern not terminated");
5230 pm = (PMOP*)newPMOP(type, 0);
5231 if (PL_multi_open == '?')
5232 pm->op_pmflags |= PMf_ONCE;
5234 while (*s && strchr("iomsx", *s))
5235 pmflag(&pm->op_pmflags,*s++);
5238 while (*s && strchr("iogcmsx", *s))
5239 pmflag(&pm->op_pmflags,*s++);
5241 pm->op_pmpermflags = pm->op_pmflags;
5243 PL_lex_op = (OP*)pm;
5244 yylval.ival = OP_MATCH;
5249 scan_subst(char *start)
5256 yylval.ival = OP_NULL;
5258 s = scan_str(start);
5262 SvREFCNT_dec(PL_lex_stuff);
5263 PL_lex_stuff = Nullsv;
5264 croak("Substitution pattern not terminated");
5267 if (s[-1] == PL_multi_open)
5270 first_start = PL_multi_start;
5274 SvREFCNT_dec(PL_lex_stuff);
5275 PL_lex_stuff = Nullsv;
5277 SvREFCNT_dec(PL_lex_repl);
5278 PL_lex_repl = Nullsv;
5279 croak("Substitution replacement not terminated");
5281 PL_multi_start = first_start; /* so whole substitution is taken together */
5283 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5289 else if (strchr("iogcmsx", *s))
5290 pmflag(&pm->op_pmflags,*s++);
5297 pm->op_pmflags |= PMf_EVAL;
5298 repl = newSVpv("",0);
5300 sv_catpv(repl, es ? "eval " : "do ");
5301 sv_catpvn(repl, "{ ", 2);
5302 sv_catsv(repl, PL_lex_repl);
5303 sv_catpvn(repl, " };", 2);
5304 SvCOMPILED_on(repl);
5305 SvREFCNT_dec(PL_lex_repl);
5309 pm->op_pmpermflags = pm->op_pmflags;
5310 PL_lex_op = (OP*)pm;
5311 yylval.ival = OP_SUBST;
5316 scan_trans(char *start)
5327 yylval.ival = OP_NULL;
5329 s = scan_str(start);
5332 SvREFCNT_dec(PL_lex_stuff);
5333 PL_lex_stuff = Nullsv;
5334 croak("Transliteration pattern not terminated");
5336 if (s[-1] == PL_multi_open)
5342 SvREFCNT_dec(PL_lex_stuff);
5343 PL_lex_stuff = Nullsv;
5345 SvREFCNT_dec(PL_lex_repl);
5346 PL_lex_repl = Nullsv;
5347 croak("Transliteration replacement not terminated");
5351 o = newSVOP(OP_TRANS, 0, 0);
5352 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5355 New(803,tbl,256,short);
5356 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5360 complement = del = squash = 0;
5361 while (strchr("cdsCU", *s)) {
5363 complement = OPpTRANS_COMPLEMENT;
5365 del = OPpTRANS_DELETE;
5367 squash = OPpTRANS_SQUASH;
5372 utf8 &= ~OPpTRANS_FROM_UTF;
5374 utf8 |= OPpTRANS_FROM_UTF;
5378 utf8 &= ~OPpTRANS_TO_UTF;
5380 utf8 |= OPpTRANS_TO_UTF;
5383 croak("Too many /C and /U options");
5388 o->op_private = del|squash|complement|utf8;
5391 yylval.ival = OP_TRANS;
5396 scan_heredoc(register char *s)
5400 I32 op_type = OP_SCALAR;
5407 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5411 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5414 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5415 if (*peek && strchr("`'\"",*peek)) {
5418 s = delimcpy(d, e, s, PL_bufend, term, &len);
5428 if (!isALNUM_lazy(s))
5429 deprecate("bare << to mean <<\"\"");
5430 for (; isALNUM_lazy(s); s++) {
5435 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5436 croak("Delimiter for here document is too long");
5439 len = d - PL_tokenbuf;
5440 #ifndef PERL_STRICT_CR
5441 d = strchr(s, '\r');
5445 while (s < PL_bufend) {
5451 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5460 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5465 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5466 herewas = newSVpv(s,PL_bufend-s);
5468 s--, herewas = newSVpv(s,d-s);
5469 s += SvCUR(herewas);
5471 tmpstr = NEWSV(87,79);
5472 sv_upgrade(tmpstr, SVt_PVIV);
5477 else if (term == '`') {
5478 op_type = OP_BACKTICK;
5479 SvIVX(tmpstr) = '\\';
5483 PL_multi_start = PL_curcop->cop_line;
5484 PL_multi_open = PL_multi_close = '<';
5485 term = *PL_tokenbuf;
5488 while (s < PL_bufend &&
5489 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5491 PL_curcop->cop_line++;
5493 if (s >= PL_bufend) {
5494 PL_curcop->cop_line = PL_multi_start;
5495 missingterm(PL_tokenbuf);
5497 sv_setpvn(tmpstr,d+1,s-d);
5499 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5501 sv_catpvn(herewas,s,PL_bufend-s);
5502 sv_setsv(PL_linestr,herewas);
5503 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5504 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5507 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5508 while (s >= PL_bufend) { /* multiple line string? */
5510 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5511 PL_curcop->cop_line = PL_multi_start;
5512 missingterm(PL_tokenbuf);
5514 PL_curcop->cop_line++;
5515 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5516 #ifndef PERL_STRICT_CR
5517 if (PL_bufend - PL_linestart >= 2) {
5518 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5519 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5521 PL_bufend[-2] = '\n';
5523 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5525 else if (PL_bufend[-1] == '\r')
5526 PL_bufend[-1] = '\n';
5528 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5529 PL_bufend[-1] = '\n';
5531 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5532 SV *sv = NEWSV(88,0);
5534 sv_upgrade(sv, SVt_PVMG);
5535 sv_setsv(sv,PL_linestr);
5536 av_store(GvAV(PL_curcop->cop_filegv),
5537 (I32)PL_curcop->cop_line,sv);
5539 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5542 sv_catsv(PL_linestr,herewas);
5543 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5547 sv_catsv(tmpstr,PL_linestr);
5550 PL_multi_end = PL_curcop->cop_line;
5552 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5553 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5554 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5556 SvREFCNT_dec(herewas);
5557 PL_lex_stuff = tmpstr;
5558 yylval.ival = op_type;
5563 takes: current position in input buffer
5564 returns: new position in input buffer
5565 side-effects: yylval and lex_op are set.
5570 <FH> read from filehandle
5571 <pkg::FH> read from package qualified filehandle
5572 <pkg'FH> read from package qualified filehandle
5573 <$fh> read from filehandle in $fh
5579 scan_inputsymbol(char *start)
5581 register char *s = start; /* current position in buffer */
5586 d = PL_tokenbuf; /* start of temp holding space */
5587 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5588 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5590 /* die if we didn't have space for the contents of the <>,
5594 if (len >= sizeof PL_tokenbuf)
5595 croak("Excessively long <> operator");
5597 croak("Unterminated <> operator");
5602 Remember, only scalar variables are interpreted as filehandles by
5603 this code. Anything more complex (e.g., <$fh{$num}>) will be
5604 treated as a glob() call.
5605 This code makes use of the fact that except for the $ at the front,
5606 a scalar variable and a filehandle look the same.
5608 if (*d == '$' && d[1]) d++;
5610 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5611 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5614 /* If we've tried to read what we allow filehandles to look like, and
5615 there's still text left, then it must be a glob() and not a getline.
5616 Use scan_str to pull out the stuff between the <> and treat it
5617 as nothing more than a string.
5620 if (d - PL_tokenbuf != len) {
5621 yylval.ival = OP_GLOB;
5623 s = scan_str(start);
5625 croak("Glob not terminated");
5629 /* we're in a filehandle read situation */
5632 /* turn <> into <ARGV> */
5634 (void)strcpy(d,"ARGV");
5636 /* if <$fh>, create the ops to turn the variable into a
5642 /* try to find it in the pad for this block, otherwise find
5643 add symbol table ops
5645 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5646 OP *o = newOP(OP_PADSV, 0);
5648 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5651 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5652 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5653 newUNOP(OP_RV2GV, 0,
5654 newUNOP(OP_RV2SV, 0,
5655 newGVOP(OP_GV, 0, gv))));
5657 /* we created the ops in lex_op, so make yylval.ival a null op */
5658 yylval.ival = OP_NULL;
5661 /* If it's none of the above, it must be a literal filehandle
5662 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5664 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5665 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5666 yylval.ival = OP_NULL;
5675 takes: start position in buffer
5676 returns: position to continue reading from buffer
5677 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5678 updates the read buffer.
5680 This subroutine pulls a string out of the input. It is called for:
5681 q single quotes q(literal text)
5682 ' single quotes 'literal text'
5683 qq double quotes qq(interpolate $here please)
5684 " double quotes "interpolate $here please"
5685 qx backticks qx(/bin/ls -l)
5686 ` backticks `/bin/ls -l`
5687 qw quote words @EXPORT_OK = qw( func() $spam )
5688 m// regexp match m/this/
5689 s/// regexp substitute s/this/that/
5690 tr/// string transliterate tr/this/that/
5691 y/// string transliterate y/this/that/
5692 ($*@) sub prototypes sub foo ($)
5693 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5695 In most of these cases (all but <>, patterns and transliterate)
5696 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5697 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5698 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5701 It skips whitespace before the string starts, and treats the first
5702 character as the delimiter. If the delimiter is one of ([{< then
5703 the corresponding "close" character )]}> is used as the closing
5704 delimiter. It allows quoting of delimiters, and if the string has
5705 balanced delimiters ([{<>}]) it allows nesting.
5707 The lexer always reads these strings into lex_stuff, except in the
5708 case of the operators which take *two* arguments (s/// and tr///)
5709 when it checks to see if lex_stuff is full (presumably with the 1st
5710 arg to s or tr) and if so puts the string into lex_repl.
5715 scan_str(char *start)
5718 SV *sv; /* scalar value: string */
5719 char *tmps; /* temp string, used for delimiter matching */
5720 register char *s = start; /* current position in the buffer */
5721 register char term; /* terminating character */
5722 register char *to; /* current position in the sv's data */
5723 I32 brackets = 1; /* bracket nesting level */
5725 /* skip space before the delimiter */
5729 /* mark where we are, in case we need to report errors */
5732 /* after skipping whitespace, the next character is the terminator */
5734 /* mark where we are */
5735 PL_multi_start = PL_curcop->cop_line;
5736 PL_multi_open = term;
5738 /* find corresponding closing delimiter */
5739 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5741 PL_multi_close = term;
5743 /* create a new SV to hold the contents. 87 is leak category, I'm
5744 assuming. 79 is the SV's initial length. What a random number. */
5746 sv_upgrade(sv, SVt_PVIV);
5748 (void)SvPOK_only(sv); /* validate pointer */
5750 /* move past delimiter and try to read a complete string */
5753 /* extend sv if need be */
5754 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5755 /* set 'to' to the next character in the sv's string */
5756 to = SvPVX(sv)+SvCUR(sv);
5758 /* if open delimiter is the close delimiter read unbridle */
5759 if (PL_multi_open == PL_multi_close) {
5760 for (; s < PL_bufend; s++,to++) {
5761 /* embedded newlines increment the current line number */
5762 if (*s == '\n' && !PL_rsfp)
5763 PL_curcop->cop_line++;
5764 /* handle quoted delimiters */
5765 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5768 /* any other quotes are simply copied straight through */
5772 /* terminate when run out of buffer (the for() condition), or
5773 have found the terminator */
5774 else if (*s == term)
5780 /* if the terminator isn't the same as the start character (e.g.,
5781 matched brackets), we have to allow more in the quoting, and
5782 be prepared for nested brackets.
5785 /* read until we run out of string, or we find the terminator */
5786 for (; s < PL_bufend; s++,to++) {
5787 /* embedded newlines increment the line count */
5788 if (*s == '\n' && !PL_rsfp)
5789 PL_curcop->cop_line++;
5790 /* backslashes can escape the open or closing characters */
5791 if (*s == '\\' && s+1 < PL_bufend) {
5792 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5797 /* allow nested opens and closes */
5798 else if (*s == PL_multi_close && --brackets <= 0)
5800 else if (*s == PL_multi_open)
5805 /* terminate the copied string and update the sv's end-of-string */
5807 SvCUR_set(sv, to - SvPVX(sv));
5810 * this next chunk reads more into the buffer if we're not done yet
5813 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5815 #ifndef PERL_STRICT_CR
5816 if (to - SvPVX(sv) >= 2) {
5817 if ((to[-2] == '\r' && to[-1] == '\n') ||
5818 (to[-2] == '\n' && to[-1] == '\r'))
5822 SvCUR_set(sv, to - SvPVX(sv));
5824 else if (to[-1] == '\r')
5827 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5831 /* if we're out of file, or a read fails, bail and reset the current
5832 line marker so we can report where the unterminated string began
5835 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5837 PL_curcop->cop_line = PL_multi_start;
5840 /* we read a line, so increment our line counter */
5841 PL_curcop->cop_line++;
5843 /* update debugger info */
5844 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5845 SV *sv = NEWSV(88,0);
5847 sv_upgrade(sv, SVt_PVMG);
5848 sv_setsv(sv,PL_linestr);
5849 av_store(GvAV(PL_curcop->cop_filegv),
5850 (I32)PL_curcop->cop_line, sv);
5853 /* having changed the buffer, we must update PL_bufend */
5854 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5857 /* at this point, we have successfully read the delimited string */
5859 PL_multi_end = PL_curcop->cop_line;
5862 /* if we allocated too much space, give some back */
5863 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5864 SvLEN_set(sv, SvCUR(sv) + 1);
5865 Renew(SvPVX(sv), SvLEN(sv), char);
5868 /* decide whether this is the first or second quoted string we've read
5881 takes: pointer to position in buffer
5882 returns: pointer to new position in buffer
5883 side-effects: builds ops for the constant in yylval.op
5885 Read a number in any of the formats that Perl accepts:
5887 0(x[0-7A-F]+)|([0-7]+)
5888 [\d_]+(\.[\d_]*)?[Ee](\d+)
5890 Underbars (_) are allowed in decimal numbers. If -w is on,
5891 underbars before a decimal point must be at three digit intervals.
5893 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5896 If it reads a number without a decimal point or an exponent, it will
5897 try converting the number to an integer and see if it can do so
5898 without loss of precision.
5902 scan_num(char *start)
5904 register char *s = start; /* current position in buffer */
5905 register char *d; /* destination in temp buffer */
5906 register char *e; /* end of temp buffer */
5907 I32 tryiv; /* used to see if it can be an int */
5908 double value; /* number read, as a double */
5909 SV *sv; /* place to put the converted number */
5910 I32 floatit; /* boolean: int or float? */
5911 char *lastub = 0; /* position of last underbar */
5912 static char number_too_long[] = "Number too long";
5914 /* We use the first character to decide what type of number this is */
5918 croak("panic: scan_num");
5920 /* if it starts with a 0, it could be an octal number, a decimal in
5921 0.13 disguise, or a hexadecimal number.
5926 u holds the "number so far"
5927 shift the power of 2 of the base (hex == 4, octal == 3)
5928 overflowed was the number more than we can hold?
5930 Shift is used when we add a digit. It also serves as an "are
5931 we in octal or hex?" indicator to disallow hex characters when
5936 bool overflowed = FALSE;
5943 /* check for a decimal in disguise */
5944 else if (s[1] == '.')
5946 /* so it must be octal */
5951 /* read the rest of the octal number */
5953 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5957 /* if we don't mention it, we're done */
5966 /* 8 and 9 are not octal */
5969 yyerror("Illegal octal digit");
5973 case '0': case '1': case '2': case '3': case '4':
5974 case '5': case '6': case '7':
5975 b = *s++ & 15; /* ASCII digit -> value of digit */
5979 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5980 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5981 /* make sure they said 0x */
5986 /* Prepare to put the digit we have onto the end
5987 of the number so far. We check for overflows.
5991 n = u << shift; /* make room for the digit */
5992 if (!overflowed && (n >> shift) != u
5993 && !(PL_hints & HINT_NEW_BINARY)) {
5994 warn("Integer overflow in %s number",
5995 (shift == 4) ? "hex" : "octal");
5998 u = n | b; /* add the digit to the end */
6003 /* if we get here, we had success: make a scalar value from
6009 if ( PL_hints & HINT_NEW_BINARY)
6010 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6015 handle decimal numbers.
6016 we're also sent here when we read a 0 as the first digit
6018 case '1': case '2': case '3': case '4': case '5':
6019 case '6': case '7': case '8': case '9': case '.':
6022 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6025 /* read next group of digits and _ and copy into d */
6026 while (isDIGIT(*s) || *s == '_') {
6027 /* skip underscores, checking for misplaced ones
6031 dTHR; /* only for ckWARN */
6032 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6033 warner(WARN_SYNTAX, "Misplaced _ in number");
6037 /* check for end of fixed-length buffer */
6039 croak(number_too_long);
6040 /* if we're ok, copy the character */
6045 /* final misplaced underbar check */
6046 if (lastub && s - lastub != 3) {
6048 if (ckWARN(WARN_SYNTAX))
6049 warner(WARN_SYNTAX, "Misplaced _ in number");
6052 /* read a decimal portion if there is one. avoid
6053 3..5 being interpreted as the number 3. followed
6056 if (*s == '.' && s[1] != '.') {
6060 /* copy, ignoring underbars, until we run out of
6061 digits. Note: no misplaced underbar checks!
6063 for (; isDIGIT(*s) || *s == '_'; s++) {
6064 /* fixed length buffer check */
6066 croak(number_too_long);
6072 /* read exponent part, if present */
6073 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6077 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6078 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6080 /* allow positive or negative exponent */
6081 if (*s == '+' || *s == '-')
6084 /* read digits of exponent (no underbars :-) */
6085 while (isDIGIT(*s)) {
6087 croak(number_too_long);
6092 /* terminate the string */
6095 /* make an sv from the string */
6097 /* reset numeric locale in case we were earlier left in Swaziland */
6098 SET_NUMERIC_STANDARD();
6099 value = atof(PL_tokenbuf);
6102 See if we can make do with an integer value without loss of
6103 precision. We use I_V to cast to an int, because some
6104 compilers have issues. Then we try casting it back and see
6105 if it was the same. We only do this if we know we
6106 specifically read an integer.
6108 Note: if floatit is true, then we don't need to do the
6112 if (!floatit && (double)tryiv == value)
6113 sv_setiv(sv, tryiv);
6115 sv_setnv(sv, value);
6116 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6117 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6118 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6122 /* make the op for the constant and return */
6124 yylval.opval = newSVOP(OP_CONST, 0, sv);
6130 scan_formline(register char *s)
6135 SV *stuff = newSVpv("",0);
6136 bool needargs = FALSE;
6139 if (*s == '.' || *s == '}') {
6141 #ifdef PERL_STRICT_CR
6142 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6144 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6149 if (PL_in_eval && !PL_rsfp) {
6150 eol = strchr(s,'\n');
6155 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6157 for (t = s; t < eol; t++) {
6158 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6160 goto enough; /* ~~ must be first line in formline */
6162 if (*t == '@' || *t == '^')
6165 sv_catpvn(stuff, s, eol-s);
6169 s = filter_gets(PL_linestr, PL_rsfp, 0);
6170 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6171 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6174 yyerror("Format not terminated");
6184 PL_lex_state = LEX_NORMAL;
6185 PL_nextval[PL_nexttoke].ival = 0;
6189 PL_lex_state = LEX_FORMLINE;
6190 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6192 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6196 SvREFCNT_dec(stuff);
6197 PL_lex_formbrack = 0;
6208 PL_cshlen = strlen(PL_cshname);
6213 start_subparse(I32 is_format, U32 flags)
6216 I32 oldsavestack_ix = PL_savestack_ix;
6217 CV* outsidecv = PL_compcv;
6221 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6223 save_I32(&PL_subline);
6224 save_item(PL_subname);
6226 SAVESPTR(PL_curpad);
6227 SAVESPTR(PL_comppad);
6228 SAVESPTR(PL_comppad_name);
6229 SAVESPTR(PL_compcv);
6230 SAVEI32(PL_comppad_name_fill);
6231 SAVEI32(PL_min_intro_pending);
6232 SAVEI32(PL_max_intro_pending);
6233 SAVEI32(PL_pad_reset_pending);
6235 PL_compcv = (CV*)NEWSV(1104,0);
6236 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6237 CvFLAGS(PL_compcv) |= flags;
6239 PL_comppad = newAV();
6240 av_push(PL_comppad, Nullsv);
6241 PL_curpad = AvARRAY(PL_comppad);
6242 PL_comppad_name = newAV();
6243 PL_comppad_name_fill = 0;
6244 PL_min_intro_pending = 0;
6246 PL_subline = PL_curcop->cop_line;
6248 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6249 PL_curpad[0] = (SV*)newAV();
6250 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6251 #endif /* USE_THREADS */
6253 comppadlist = newAV();
6254 AvREAL_off(comppadlist);
6255 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6256 av_store(comppadlist, 1, (SV*)PL_comppad);
6258 CvPADLIST(PL_compcv) = comppadlist;
6259 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6261 CvOWNER(PL_compcv) = 0;
6262 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6263 MUTEX_INIT(CvMUTEXP(PL_compcv));
6264 #endif /* USE_THREADS */
6266 return oldsavestack_ix;
6285 char *context = NULL;
6289 if (!yychar || (yychar == ';' && !PL_rsfp))
6291 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6292 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6293 while (isSPACE(*PL_oldoldbufptr))
6295 context = PL_oldoldbufptr;
6296 contlen = PL_bufptr - PL_oldoldbufptr;
6298 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6299 PL_oldbufptr != PL_bufptr) {
6300 while (isSPACE(*PL_oldbufptr))
6302 context = PL_oldbufptr;
6303 contlen = PL_bufptr - PL_oldbufptr;
6305 else if (yychar > 255)
6306 where = "next token ???";
6307 else if ((yychar & 127) == 127) {
6308 if (PL_lex_state == LEX_NORMAL ||
6309 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6310 where = "at end of line";
6311 else if (PL_lex_inpat)
6312 where = "within pattern";
6314 where = "within string";
6317 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6319 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6320 else if (isPRINT_LC(yychar))
6321 sv_catpvf(where_sv, "%c", yychar);
6323 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6324 where = SvPVX(where_sv);
6326 msg = sv_2mortal(newSVpv(s, 0));
6327 sv_catpvf(msg, " at %_ line %ld, ",
6328 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6330 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6332 sv_catpvf(msg, "%s\n", where);
6333 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6335 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6336 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6341 else if (PL_in_eval)
6342 sv_catsv(ERRSV, msg);
6344 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6345 if (++PL_error_count >= 10)
6346 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6348 PL_in_my_stash = Nullhv;