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;
117 # define yylval (*yylval_pointer)
118 # define yychar (*yychar_pointer)
119 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
121 # define PERL_YYLEX_PARAM
124 #include "keywords.h"
129 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
131 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
132 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
133 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
134 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
135 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
136 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
137 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
138 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
139 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
140 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
141 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
142 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
143 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
144 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
145 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
146 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
147 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
148 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
149 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
150 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
152 /* This bit of chicanery makes a unary function followed by
153 * a parenthesis into a function with one argument, highest precedence.
155 #define UNI(f) return(yylval.ival = f, \
158 PL_last_uni = PL_oldbufptr, \
159 PL_last_lop_op = f, \
160 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
162 #define UNIBRACK(f) return(yylval.ival = f, \
164 PL_last_uni = PL_oldbufptr, \
165 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
167 /* grandfather return to old style */
168 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
173 if (*PL_bufptr == '=') {
175 if (toketype == ANDAND)
176 yylval.ival = OP_ANDASSIGN;
177 else if (toketype == OROR)
178 yylval.ival = OP_ORASSIGN;
185 no_op(char *what, char *s)
187 char *oldbp = PL_bufptr;
188 bool is_first = (PL_oldbufptr == PL_linestart);
191 yywarn(form("%s found where operator expected", what));
193 warn("\t(Missing semicolon on previous line?)\n");
194 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
196 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
197 if (t < PL_bufptr && isSPACE(*t))
198 warn("\t(Do you need to predeclare %.*s?)\n",
199 t - PL_oldoldbufptr, PL_oldoldbufptr);
203 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
213 char *nl = strrchr(s,'\n');
219 iscntrl(PL_multi_close)
221 PL_multi_close < 32 || PL_multi_close == 127
225 tmpbuf[1] = toCTRL(PL_multi_close);
231 *tmpbuf = PL_multi_close;
235 q = strchr(s,'"') ? '\'' : '"';
236 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
243 if (ckWARN(WARN_DEPRECATED))
244 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
250 deprecate("comma-less variable list");
256 win32_textfilter(int idx, SV *sv, int maxlen)
258 I32 count = FILTER_READ(idx+1, sv, maxlen);
259 if (count > 0 && !maxlen)
260 win32_strip_return(sv);
268 utf16_textfilter(int idx, SV *sv, int maxlen)
270 I32 count = FILTER_READ(idx+1, sv, maxlen);
274 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
275 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
276 sv_usepvn(sv, (char*)tmps, tend - tmps);
283 utf16rev_textfilter(int idx, SV *sv, int maxlen)
285 I32 count = FILTER_READ(idx+1, sv, maxlen);
289 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
290 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
291 sv_usepvn(sv, (char*)tmps, tend - tmps);
306 SAVEI32(PL_lex_dojoin);
307 SAVEI32(PL_lex_brackets);
308 SAVEI32(PL_lex_fakebrack);
309 SAVEI32(PL_lex_casemods);
310 SAVEI32(PL_lex_starts);
311 SAVEI32(PL_lex_state);
312 SAVESPTR(PL_lex_inpat);
313 SAVEI32(PL_lex_inwhat);
314 SAVEI16(PL_curcop->cop_line);
317 SAVEPPTR(PL_oldbufptr);
318 SAVEPPTR(PL_oldoldbufptr);
319 SAVEPPTR(PL_linestart);
320 SAVESPTR(PL_linestr);
321 SAVEPPTR(PL_lex_brackstack);
322 SAVEPPTR(PL_lex_casestack);
323 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
324 SAVESPTR(PL_lex_stuff);
325 SAVEI32(PL_lex_defer);
326 SAVESPTR(PL_lex_repl);
327 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
328 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
330 PL_lex_state = LEX_NORMAL;
334 PL_lex_fakebrack = 0;
335 New(899, PL_lex_brackstack, 120, char);
336 New(899, PL_lex_casestack, 12, char);
337 SAVEFREEPV(PL_lex_brackstack);
338 SAVEFREEPV(PL_lex_casestack);
340 *PL_lex_casestack = '\0';
343 PL_lex_stuff = Nullsv;
344 PL_lex_repl = Nullsv;
348 if (SvREADONLY(PL_linestr))
349 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
350 s = SvPV(PL_linestr, len);
351 if (len && s[len-1] != ';') {
352 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
353 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
354 sv_catpvn(PL_linestr, "\n;", 2);
356 SvTEMP_off(PL_linestr);
357 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
358 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
360 PL_rs = newSVpv("\n", 1);
367 PL_doextract = FALSE;
371 restore_rsfp(void *f)
373 PerlIO *fp = (PerlIO*)f;
375 if (PL_rsfp == PerlIO_stdin())
376 PerlIO_clearerr(PL_rsfp);
377 else if (PL_rsfp && (PL_rsfp != fp))
378 PerlIO_close(PL_rsfp);
383 restore_expect(void *e)
385 /* a safe way to store a small integer in a pointer */
386 PL_expect = (expectation)((char *)e - PL_tokenbuf);
390 restore_lex_expect(void *e)
392 /* a safe way to store a small integer in a pointer */
393 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
405 PL_curcop->cop_line++;
408 while (*s == ' ' || *s == '\t') s++;
409 if (strnEQ(s, "line ", 5)) {
418 while (*s == ' ' || *s == '\t')
420 if (*s == '"' && (t = strchr(s+1, '"')))
424 return; /* false alarm */
425 for (t = s; !isSPACE(*t); t++) ;
430 PL_curcop->cop_filegv = gv_fetchfile(s);
432 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
434 PL_curcop->cop_line = atoi(n)-1;
438 skipspace(register char *s)
441 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
442 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
448 while (s < PL_bufend && isSPACE(*s))
450 if (s < PL_bufend && *s == '#') {
451 while (s < PL_bufend && *s != '\n')
456 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
458 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
459 if (PL_minus_n || PL_minus_p) {
460 sv_setpv(PL_linestr,PL_minus_p ?
461 ";}continue{print or die qq(-p destination: $!\\n)" :
463 sv_catpv(PL_linestr,";}");
464 PL_minus_n = PL_minus_p = 0;
467 sv_setpv(PL_linestr,";");
468 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
469 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
470 if (PL_preprocess && !PL_in_eval)
471 (void)PerlProc_pclose(PL_rsfp);
472 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
473 PerlIO_clearerr(PL_rsfp);
475 (void)PerlIO_close(PL_rsfp);
479 PL_linestart = PL_bufptr = s + prevlen;
480 PL_bufend = s + SvCUR(PL_linestr);
483 if (PERLDB_LINE && PL_curstash != PL_debstash) {
484 SV *sv = NEWSV(85,0);
486 sv_upgrade(sv, SVt_PVMG);
487 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
488 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
499 if (PL_oldoldbufptr != PL_last_uni)
501 while (isSPACE(*PL_last_uni))
503 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
504 if ((t = strchr(s, '(')) && t < PL_bufptr)
508 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
515 #define UNI(f) return uni(f,s)
523 PL_last_uni = PL_oldbufptr;
534 #endif /* CRIPPLED_CC */
536 #define LOP(f,x) return lop(f,x,s)
539 lop(I32 f, expectation x, char *s)
546 PL_last_lop = PL_oldbufptr;
562 PL_nexttype[PL_nexttoke] = type;
564 if (PL_lex_state != LEX_KNOWNEXT) {
565 PL_lex_defer = PL_lex_state;
566 PL_lex_expect = PL_expect;
567 PL_lex_state = LEX_KNOWNEXT;
572 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
577 start = skipspace(start);
579 if (isIDFIRST_lazy(s) ||
580 (allow_pack && *s == ':') ||
581 (allow_initial_tick && *s == '\'') )
583 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
584 if (check_keyword && keyword(PL_tokenbuf, len))
586 if (token == METHOD) {
591 PL_expect = XOPERATOR;
596 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
597 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
604 force_ident(register char *s, int kind)
607 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
608 PL_nextval[PL_nexttoke].opval = o;
611 dTHR; /* just for in_eval */
612 o->op_private = OPpCONST_ENTERED;
613 /* XXX see note in pp_entereval() for why we forgo typo
614 warnings if the symbol must be introduced in an eval.
616 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
617 kind == '$' ? SVt_PV :
618 kind == '@' ? SVt_PVAV :
619 kind == '%' ? SVt_PVHV :
627 force_version(char *s)
629 OP *version = Nullop;
633 /* default VERSION number -- GBARR */
638 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
639 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
641 /* real VERSION number -- GBARR */
642 version = yylval.opval;
646 /* NOTE: The parser sees the package name and the VERSION swapped */
647 PL_nextval[PL_nexttoke].opval = version;
665 s = SvPV_force(sv, len);
669 while (s < send && *s != '\\')
674 if ( PL_hints & HINT_NEW_STRING )
675 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
678 if (s + 1 < send && (s[1] == '\\'))
679 s++; /* all that, just for this */
684 SvCUR_set(sv, d - SvPVX(sv));
686 if ( PL_hints & HINT_NEW_STRING )
687 return new_constant(NULL, 0, "q", sv, pv, "q");
694 register I32 op_type = yylval.ival;
696 if (op_type == OP_NULL) {
697 yylval.opval = PL_lex_op;
701 if (op_type == OP_CONST || op_type == OP_READLINE) {
702 SV *sv = tokeq(PL_lex_stuff);
704 if (SvTYPE(sv) == SVt_PVIV) {
705 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
711 nsv = newSVpv(p, len);
715 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
716 PL_lex_stuff = Nullsv;
720 PL_sublex_info.super_state = PL_lex_state;
721 PL_sublex_info.sub_inwhat = op_type;
722 PL_sublex_info.sub_op = PL_lex_op;
723 PL_lex_state = LEX_INTERPPUSH;
727 yylval.opval = PL_lex_op;
741 PL_lex_state = PL_sublex_info.super_state;
742 SAVEI32(PL_lex_dojoin);
743 SAVEI32(PL_lex_brackets);
744 SAVEI32(PL_lex_fakebrack);
745 SAVEI32(PL_lex_casemods);
746 SAVEI32(PL_lex_starts);
747 SAVEI32(PL_lex_state);
748 SAVESPTR(PL_lex_inpat);
749 SAVEI32(PL_lex_inwhat);
750 SAVEI16(PL_curcop->cop_line);
752 SAVEPPTR(PL_oldbufptr);
753 SAVEPPTR(PL_oldoldbufptr);
754 SAVEPPTR(PL_linestart);
755 SAVESPTR(PL_linestr);
756 SAVEPPTR(PL_lex_brackstack);
757 SAVEPPTR(PL_lex_casestack);
759 PL_linestr = PL_lex_stuff;
760 PL_lex_stuff = Nullsv;
762 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
763 PL_bufend += SvCUR(PL_linestr);
764 SAVEFREESV(PL_linestr);
766 PL_lex_dojoin = FALSE;
768 PL_lex_fakebrack = 0;
769 New(899, PL_lex_brackstack, 120, char);
770 New(899, PL_lex_casestack, 12, char);
771 SAVEFREEPV(PL_lex_brackstack);
772 SAVEFREEPV(PL_lex_casestack);
774 *PL_lex_casestack = '\0';
776 PL_lex_state = LEX_INTERPCONCAT;
777 PL_curcop->cop_line = PL_multi_start;
779 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
780 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
781 PL_lex_inpat = PL_sublex_info.sub_op;
783 PL_lex_inpat = Nullop;
791 if (!PL_lex_starts++) {
792 PL_expect = XOPERATOR;
793 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
797 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
798 PL_lex_state = LEX_INTERPCASEMOD;
799 return yylex(PERL_YYLEX_PARAM);
802 /* Is there a right-hand side to take care of? */
803 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
804 PL_linestr = PL_lex_repl;
806 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
807 PL_bufend += SvCUR(PL_linestr);
808 SAVEFREESV(PL_linestr);
809 PL_lex_dojoin = FALSE;
811 PL_lex_fakebrack = 0;
813 *PL_lex_casestack = '\0';
815 if (SvCOMPILED(PL_lex_repl)) {
816 PL_lex_state = LEX_INTERPNORMAL;
820 PL_lex_state = LEX_INTERPCONCAT;
821 PL_lex_repl = Nullsv;
826 PL_bufend = SvPVX(PL_linestr);
827 PL_bufend += SvCUR(PL_linestr);
828 PL_expect = XOPERATOR;
836 Extracts a pattern, double-quoted string, or transliteration. This
839 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
840 processing a pattern (PL_lex_inpat is true), a transliteration
841 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
843 Returns a pointer to the character scanned up to. Iff this is
844 advanced from the start pointer supplied (ie if anything was
845 successfully parsed), will leave an OP for the substring scanned
846 in yylval. Caller must intuit reason for not parsing further
847 by looking at the next characters herself.
851 double-quoted style: \r and \n
852 regexp special ones: \D \s
854 backrefs: \1 (deprecated in substitution replacements)
855 case and quoting: \U \Q \E
856 stops on @ and $, but not for $ as tail anchor
859 characters are VERY literal, except for - not at the start or end
860 of the string, which indicates a range. scan_const expands the
861 range to the full set of intermediate characters.
863 In double-quoted strings:
865 double-quoted style: \r and \n
867 backrefs: \1 (deprecated)
868 case and quoting: \U \Q \E
871 scan_const does *not* construct ops to handle interpolated strings.
872 It stops processing as soon as it finds an embedded $ or @ variable
873 and leaves it to the caller to work out what's going on.
875 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
877 $ in pattern could be $foo or could be tail anchor. Assumption:
878 it's a tail anchor if $ is the last thing in the string, or if it's
879 followed by one of ")| \n\t"
881 \1 (backreferences) are turned into $1
883 The structure of the code is
884 while (there's a character to process) {
885 handle transliteration ranges
887 skip # initiated comments in //x patterns
888 check for embedded @foo
889 check for embedded scalars
891 leave intact backslashes from leave (below)
892 deprecate \1 in strings and sub replacements
893 handle string-changing backslashes \l \U \Q \E, etc.
894 switch (what was escaped) {
895 handle - in a transliteration (becomes a literal -)
896 handle \132 octal characters
897 handle 0x15 hex characters
898 handle \cV (control V)
899 handle printf backslashes (\f, \r, \n, etc)
902 } (end while character to read)
907 scan_const(char *start)
909 register char *send = PL_bufend; /* end of the constant */
910 SV *sv = NEWSV(93, send - start); /* sv for the constant */
911 register char *s = start; /* start of the constant */
912 register char *d = SvPVX(sv); /* destination for copies */
913 bool dorange = FALSE; /* are we in a translit range? */
915 I32 utf = PL_lex_inwhat == OP_TRANS
916 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
918 I32 thisutf = PL_lex_inwhat == OP_TRANS
919 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
922 /* leaveit is the set of acceptably-backslashed characters */
925 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
928 while (s < send || dorange) {
929 /* get transliterations out of the way (they're most literal) */
930 if (PL_lex_inwhat == OP_TRANS) {
931 /* expand a range A-Z to the full set of characters. AIE! */
933 I32 i; /* current expanded character */
934 I32 min; /* first character in range */
935 I32 max; /* last character in range */
937 i = d - SvPVX(sv); /* remember current offset */
938 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
939 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
940 d -= 2; /* eat the first char and the - */
942 min = (U8)*d; /* first char in range */
943 max = (U8)d[1]; /* last char in range */
946 if ((isLOWER(min) && isLOWER(max)) ||
947 (isUPPER(min) && isUPPER(max))) {
949 for (i = min; i <= max; i++)
953 for (i = min; i <= max; i++)
960 for (i = min; i <= max; i++)
963 /* mark the range as done, and continue */
968 /* range begins (ignore - as first or last char) */
969 else if (*s == '-' && s+1 < send && s != start) {
971 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
980 /* if we get here, we're not doing a transliteration */
982 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
983 except for the last char, which will be done separately. */
984 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
986 while (s < send && *s != ')')
988 } else if (s[2] == '{'
989 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
991 char *regparse = s + (s[2] == '{' ? 3 : 4);
994 while (count && (c = *regparse)) {
995 if (c == '\\' && regparse[1])
1003 if (*regparse != ')') {
1004 regparse--; /* Leave one char for continuation. */
1005 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1007 while (s < regparse)
1012 /* likewise skip #-initiated comments in //x patterns */
1013 else if (*s == '#' && PL_lex_inpat &&
1014 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1015 while (s+1 < send && *s != '\n')
1019 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1020 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1023 /* check for embedded scalars. only stop if we're sure it's a
1026 else if (*s == '$') {
1027 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1029 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1030 break; /* in regexp, $ might be tail anchor */
1033 /* (now in tr/// code again) */
1035 if (*s & 0x80 && thisutf) {
1036 dTHR; /* only for ckWARN */
1037 if (ckWARN(WARN_UTF8)) {
1038 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1048 if (*s == '\\' && s+1 < send) {
1051 /* some backslashes we leave behind */
1052 if (*s && strchr(leaveit, *s)) {
1058 /* deprecate \1 in strings and substitution replacements */
1059 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1060 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1062 dTHR; /* only for ckWARN */
1063 if (ckWARN(WARN_SYNTAX))
1064 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1069 /* string-change backslash escapes */
1070 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1075 /* if we get here, it's either a quoted -, or a digit */
1078 /* quoted - in transliterations */
1080 if (PL_lex_inwhat == OP_TRANS) {
1085 /* default action is to copy the quoted character */
1090 /* \132 indicates an octal constant */
1091 case '0': case '1': case '2': case '3':
1092 case '4': case '5': case '6': case '7':
1093 *d++ = scan_oct(s, 3, &len);
1097 /* \x24 indicates a hex constant */
1101 char* e = strchr(s, '}');
1104 yyerror("Missing right brace on \\x{}");
1109 if (ckWARN(WARN_UTF8))
1111 "Use of \\x{} without utf8 declaration");
1113 /* note: utf always shorter than hex */
1114 d = (char*)uv_to_utf8((U8*)d,
1115 scan_hex(s + 1, e - s - 1, &len));
1120 UV uv = (UV)scan_hex(s, 2, &len);
1121 if (utf && PL_lex_inwhat == OP_TRANS &&
1122 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1124 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1127 if (uv >= 127 && UTF) {
1129 if (ckWARN(WARN_UTF8))
1131 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1140 /* \c is a control character */
1154 /* printf-style backslashes, formfeeds, newlines, etc */
1180 } /* end if (backslash) */
1183 } /* while loop to process each character */
1185 /* terminate the string and set up the sv */
1187 SvCUR_set(sv, d - SvPVX(sv));
1190 /* shrink the sv if we allocated more than we used */
1191 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1192 SvLEN_set(sv, SvCUR(sv) + 1);
1193 Renew(SvPVX(sv), SvLEN(sv), char);
1196 /* return the substring (via yylval) only if we parsed anything */
1197 if (s > PL_bufptr) {
1198 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1199 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1201 ( PL_lex_inwhat == OP_TRANS
1203 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1206 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1212 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1214 intuit_more(register char *s)
1216 if (PL_lex_brackets)
1218 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1220 if (*s != '{' && *s != '[')
1225 /* In a pattern, so maybe we have {n,m}. */
1242 /* On the other hand, maybe we have a character class */
1245 if (*s == ']' || *s == '^')
1248 int weight = 2; /* let's weigh the evidence */
1250 unsigned char un_char = 255, last_un_char;
1251 char *send = strchr(s,']');
1252 char tmpbuf[sizeof PL_tokenbuf * 4];
1254 if (!send) /* has to be an expression */
1257 Zero(seen,256,char);
1260 else if (isDIGIT(*s)) {
1262 if (isDIGIT(s[1]) && s[2] == ']')
1268 for (; s < send; s++) {
1269 last_un_char = un_char;
1270 un_char = (unsigned char)*s;
1275 weight -= seen[un_char] * 10;
1276 if (isALNUM_lazy(s+1)) {
1277 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1278 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1283 else if (*s == '$' && s[1] &&
1284 strchr("[#!%*<>()-=",s[1])) {
1285 if (/*{*/ strchr("])} =",s[2]))
1294 if (strchr("wds]",s[1]))
1296 else if (seen['\''] || seen['"'])
1298 else if (strchr("rnftbxcav",s[1]))
1300 else if (isDIGIT(s[1])) {
1302 while (s[1] && isDIGIT(s[1]))
1312 if (strchr("aA01! ",last_un_char))
1314 if (strchr("zZ79~",s[1]))
1316 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1317 weight -= 5; /* cope with negative subscript */
1320 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1321 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1326 if (keyword(tmpbuf, d - tmpbuf))
1329 if (un_char == last_un_char + 1)
1331 weight -= seen[un_char];
1336 if (weight >= 0) /* probably a character class */
1344 intuit_method(char *start, GV *gv)
1346 char *s = start + (*start == '$');
1347 char tmpbuf[sizeof PL_tokenbuf];
1355 if ((cv = GvCVu(gv))) {
1356 char *proto = SvPVX(cv);
1366 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1367 if (*start == '$') {
1368 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1373 return *s == '(' ? FUNCMETH : METHOD;
1375 if (!keyword(tmpbuf, len)) {
1376 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1381 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1382 if (indirgv && GvCVu(indirgv))
1384 /* filehandle or package name makes it a method */
1385 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1387 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1388 return 0; /* no assumptions -- "=>" quotes bearword */
1390 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1392 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1396 return *s == '(' ? FUNCMETH : METHOD;
1406 char *pdb = PerlEnv_getenv("PERL5DB");
1410 SETERRNO(0,SS$_NORMAL);
1411 return "BEGIN { require 'perl5db.pl' }";
1417 /* Encoded script support. filter_add() effectively inserts a
1418 * 'pre-processing' function into the current source input stream.
1419 * Note that the filter function only applies to the current source file
1420 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1422 * The datasv parameter (which may be NULL) can be used to pass
1423 * private data to this instance of the filter. The filter function
1424 * can recover the SV using the FILTER_DATA macro and use it to
1425 * store private buffers and state information.
1427 * The supplied datasv parameter is upgraded to a PVIO type
1428 * and the IoDIRP field is used to store the function pointer.
1429 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1430 * private use must be set using malloc'd pointers.
1432 static int filter_debug = 0;
1435 filter_add(filter_t funcp, SV *datasv)
1437 if (!funcp){ /* temporary handy debugging hack to be deleted */
1438 filter_debug = atoi((char*)datasv);
1441 if (!PL_rsfp_filters)
1442 PL_rsfp_filters = newAV();
1444 datasv = NEWSV(255,0);
1445 if (!SvUPGRADE(datasv, SVt_PVIO))
1446 die("Can't upgrade filter_add data to SVt_PVIO");
1447 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1449 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1450 av_unshift(PL_rsfp_filters, 1);
1451 av_store(PL_rsfp_filters, 0, datasv) ;
1456 /* Delete most recently added instance of this filter function. */
1458 filter_del(filter_t funcp)
1461 warn("filter_del func %p", funcp);
1462 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1464 /* if filter is on top of stack (usual case) just pop it off */
1465 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1466 sv_free(av_pop(PL_rsfp_filters));
1470 /* we need to search for the correct entry and clear it */
1471 die("filter_del can only delete in reverse order (currently)");
1475 /* Invoke the n'th filter function for the current rsfp. */
1477 filter_read(int idx, SV *buf_sv, int maxlen)
1480 /* 0 = read one text line */
1485 if (!PL_rsfp_filters)
1487 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1488 /* Provide a default input filter to make life easy. */
1489 /* Note that we append to the line. This is handy. */
1491 warn("filter_read %d: from rsfp\n", idx);
1495 int old_len = SvCUR(buf_sv) ;
1497 /* ensure buf_sv is large enough */
1498 SvGROW(buf_sv, old_len + maxlen) ;
1499 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1500 if (PerlIO_error(PL_rsfp))
1501 return -1; /* error */
1503 return 0 ; /* end of file */
1505 SvCUR_set(buf_sv, old_len + len) ;
1508 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1509 if (PerlIO_error(PL_rsfp))
1510 return -1; /* error */
1512 return 0 ; /* end of file */
1515 return SvCUR(buf_sv);
1517 /* Skip this filter slot if filter has been deleted */
1518 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1520 warn("filter_read %d: skipped (filter deleted)\n", idx);
1521 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1523 /* Get function pointer hidden within datasv */
1524 funcp = (filter_t)IoDIRP(datasv);
1526 warn("filter_read %d: via function %p (%s)\n",
1527 idx, funcp, SvPV(datasv,PL_na));
1528 /* Call function. The function is expected to */
1529 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1530 /* Return: <0:error, =0:eof, >0:not eof */
1531 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1535 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1538 if (!PL_rsfp_filters) {
1539 filter_add(win32_textfilter,NULL);
1542 if (PL_rsfp_filters) {
1545 SvCUR_set(sv, 0); /* start with empty line */
1546 if (FILTER_READ(0, sv, 0) > 0)
1547 return ( SvPVX(sv) ) ;
1552 return (sv_gets(sv, fp, append));
1557 static char* exp_name[] =
1558 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1564 Works out what to call the token just pulled out of the input
1565 stream. The yacc parser takes care of taking the ops we return and
1566 stitching them into a tree.
1572 if read an identifier
1573 if we're in a my declaration
1574 croak if they tried to say my($foo::bar)
1575 build the ops for a my() declaration
1576 if it's an access to a my() variable
1577 are we in a sort block?
1578 croak if my($a); $a <=> $b
1579 build ops for access to a my() variable
1580 if in a dq string, and they've said @foo and we can't find @foo
1582 build ops for a bareword
1583 if we already built the token before, use it.
1586 int yylex(PERL_YYLEX_PARAM_DECL)
1596 #ifdef USE_PURE_BISON
1597 yylval_pointer = lvalp;
1598 yychar_pointer = lcharp;
1601 /* check if there's an identifier for us to look at */
1602 if (PL_pending_ident) {
1603 /* pit holds the identifier we read and pending_ident is reset */
1604 char pit = PL_pending_ident;
1605 PL_pending_ident = 0;
1607 /* if we're in a my(), we can't allow dynamics here.
1608 $foo'bar has already been turned into $foo::bar, so
1609 just check for colons.
1611 if it's a legal name, the OP is a PADANY.
1614 if (strchr(PL_tokenbuf,':'))
1615 croak(PL_no_myglob,PL_tokenbuf);
1617 yylval.opval = newOP(OP_PADANY, 0);
1618 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1623 build the ops for accesses to a my() variable.
1625 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1626 then used in a comparison. This catches most, but not
1627 all cases. For instance, it catches
1628 sort { my($a); $a <=> $b }
1630 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1631 (although why you'd do that is anyone's guess).
1634 if (!strchr(PL_tokenbuf,':')) {
1636 /* Check for single character per-thread SVs */
1637 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1638 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1639 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1641 yylval.opval = newOP(OP_THREADSV, 0);
1642 yylval.opval->op_targ = tmp;
1645 #endif /* USE_THREADS */
1646 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1647 /* if it's a sort block and they're naming $a or $b */
1648 if (PL_last_lop_op == OP_SORT &&
1649 PL_tokenbuf[0] == '$' &&
1650 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1653 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1654 d < PL_bufend && *d != '\n';
1657 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1658 croak("Can't use \"my %s\" in sort comparison",
1664 yylval.opval = newOP(OP_PADANY, 0);
1665 yylval.opval->op_targ = tmp;
1671 Whine if they've said @foo in a doublequoted string,
1672 and @foo isn't a variable we can find in the symbol
1675 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1676 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1677 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1678 yyerror(form("In string, %s now must be written as \\%s",
1679 PL_tokenbuf, PL_tokenbuf));
1682 /* build ops for a bareword */
1683 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1684 yylval.opval->op_private = OPpCONST_ENTERED;
1685 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1686 ((PL_tokenbuf[0] == '$') ? SVt_PV
1687 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1692 /* no identifier pending identification */
1694 switch (PL_lex_state) {
1696 case LEX_NORMAL: /* Some compilers will produce faster */
1697 case LEX_INTERPNORMAL: /* code if we comment these out. */
1701 /* when we're already built the next token, just pull it out the queue */
1704 yylval = PL_nextval[PL_nexttoke];
1706 PL_lex_state = PL_lex_defer;
1707 PL_expect = PL_lex_expect;
1708 PL_lex_defer = LEX_NORMAL;
1710 return(PL_nexttype[PL_nexttoke]);
1712 /* interpolated case modifiers like \L \U, including \Q and \E.
1713 when we get here, PL_bufptr is at the \
1715 case LEX_INTERPCASEMOD:
1717 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1718 croak("panic: INTERPCASEMOD");
1720 /* handle \E or end of string */
1721 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1725 if (PL_lex_casemods) {
1726 oldmod = PL_lex_casestack[--PL_lex_casemods];
1727 PL_lex_casestack[PL_lex_casemods] = '\0';
1729 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1731 PL_lex_state = LEX_INTERPCONCAT;
1735 if (PL_bufptr != PL_bufend)
1737 PL_lex_state = LEX_INTERPCONCAT;
1738 return yylex(PERL_YYLEX_PARAM);
1742 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1743 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1744 if (strchr("LU", *s) &&
1745 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1747 PL_lex_casestack[--PL_lex_casemods] = '\0';
1750 if (PL_lex_casemods > 10) {
1751 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1752 if (newlb != PL_lex_casestack) {
1754 PL_lex_casestack = newlb;
1757 PL_lex_casestack[PL_lex_casemods++] = *s;
1758 PL_lex_casestack[PL_lex_casemods] = '\0';
1759 PL_lex_state = LEX_INTERPCONCAT;
1760 PL_nextval[PL_nexttoke].ival = 0;
1763 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1765 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1767 PL_nextval[PL_nexttoke].ival = OP_LC;
1769 PL_nextval[PL_nexttoke].ival = OP_UC;
1771 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1773 croak("panic: yylex");
1776 if (PL_lex_starts) {
1782 return yylex(PERL_YYLEX_PARAM);
1785 case LEX_INTERPPUSH:
1786 return sublex_push();
1788 case LEX_INTERPSTART:
1789 if (PL_bufptr == PL_bufend)
1790 return sublex_done();
1792 PL_lex_dojoin = (*PL_bufptr == '@');
1793 PL_lex_state = LEX_INTERPNORMAL;
1794 if (PL_lex_dojoin) {
1795 PL_nextval[PL_nexttoke].ival = 0;
1798 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1799 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1800 force_next(PRIVATEREF);
1802 force_ident("\"", '$');
1803 #endif /* USE_THREADS */
1804 PL_nextval[PL_nexttoke].ival = 0;
1806 PL_nextval[PL_nexttoke].ival = 0;
1808 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1811 if (PL_lex_starts++) {
1815 return yylex(PERL_YYLEX_PARAM);
1817 case LEX_INTERPENDMAYBE:
1818 if (intuit_more(PL_bufptr)) {
1819 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1825 if (PL_lex_dojoin) {
1826 PL_lex_dojoin = FALSE;
1827 PL_lex_state = LEX_INTERPCONCAT;
1831 case LEX_INTERPCONCAT:
1833 if (PL_lex_brackets)
1834 croak("panic: INTERPCONCAT");
1836 if (PL_bufptr == PL_bufend)
1837 return sublex_done();
1839 if (SvIVX(PL_linestr) == '\'') {
1840 SV *sv = newSVsv(PL_linestr);
1843 else if ( PL_hints & HINT_NEW_RE )
1844 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1845 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1849 s = scan_const(PL_bufptr);
1851 PL_lex_state = LEX_INTERPCASEMOD;
1853 PL_lex_state = LEX_INTERPSTART;
1856 if (s != PL_bufptr) {
1857 PL_nextval[PL_nexttoke] = yylval;
1860 if (PL_lex_starts++)
1864 return yylex(PERL_YYLEX_PARAM);
1868 return yylex(PERL_YYLEX_PARAM);
1870 PL_lex_state = LEX_NORMAL;
1871 s = scan_formline(PL_bufptr);
1872 if (!PL_lex_formbrack)
1878 PL_oldoldbufptr = PL_oldbufptr;
1881 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1887 if (isIDFIRST_lazy(s))
1889 croak("Unrecognized character \\x%02X", *s & 255);
1892 goto fake_eof; /* emulate EOF on ^D or ^Z */
1897 if (PL_lex_brackets)
1898 yyerror("Missing right bracket");
1901 if (s++ < PL_bufend)
1902 goto retry; /* ignore stray nulls */
1905 if (!PL_in_eval && !PL_preambled) {
1906 PL_preambled = TRUE;
1907 sv_setpv(PL_linestr,incl_perldb());
1908 if (SvCUR(PL_linestr))
1909 sv_catpv(PL_linestr,";");
1911 while(AvFILLp(PL_preambleav) >= 0) {
1912 SV *tmpsv = av_shift(PL_preambleav);
1913 sv_catsv(PL_linestr, tmpsv);
1914 sv_catpv(PL_linestr, ";");
1917 sv_free((SV*)PL_preambleav);
1918 PL_preambleav = NULL;
1920 if (PL_minus_n || PL_minus_p) {
1921 sv_catpv(PL_linestr, "LINE: while (<>) {");
1923 sv_catpv(PL_linestr,"chomp;");
1925 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1927 GvIMPORTED_AV_on(gv);
1929 if (strchr("/'\"", *PL_splitstr)
1930 && strchr(PL_splitstr + 1, *PL_splitstr))
1931 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1934 s = "'~#\200\1'"; /* surely one char is unused...*/
1935 while (s[1] && strchr(PL_splitstr, *s)) s++;
1937 sv_catpvf(PL_linestr, "@F=split(%s%c",
1938 "q" + (delim == '\''), delim);
1939 for (s = PL_splitstr; *s; s++) {
1941 sv_catpvn(PL_linestr, "\\", 1);
1942 sv_catpvn(PL_linestr, s, 1);
1944 sv_catpvf(PL_linestr, "%c);", delim);
1948 sv_catpv(PL_linestr,"@F=split(' ');");
1951 sv_catpv(PL_linestr, "\n");
1952 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1953 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1954 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1955 SV *sv = NEWSV(85,0);
1957 sv_upgrade(sv, SVt_PVMG);
1958 sv_setsv(sv,PL_linestr);
1959 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1964 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1967 if (PL_preprocess && !PL_in_eval)
1968 (void)PerlProc_pclose(PL_rsfp);
1969 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1970 PerlIO_clearerr(PL_rsfp);
1972 (void)PerlIO_close(PL_rsfp);
1974 PL_doextract = FALSE;
1976 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1977 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1978 sv_catpv(PL_linestr,";}");
1979 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1980 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1981 PL_minus_n = PL_minus_p = 0;
1984 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1985 sv_setpv(PL_linestr,"");
1986 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1989 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1990 PL_doextract = FALSE;
1992 /* Incest with pod. */
1993 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1994 sv_setpv(PL_linestr, "");
1995 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1996 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1997 PL_doextract = FALSE;
2001 } while (PL_doextract);
2002 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2003 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2004 SV *sv = NEWSV(85,0);
2006 sv_upgrade(sv, SVt_PVMG);
2007 sv_setsv(sv,PL_linestr);
2008 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2010 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2011 if (PL_curcop->cop_line == 1) {
2012 while (s < PL_bufend && isSPACE(*s))
2014 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2018 if (*s == '#' && *(s+1) == '!')
2020 #ifdef ALTERNATE_SHEBANG
2022 static char as[] = ALTERNATE_SHEBANG;
2023 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2024 d = s + (sizeof(as) - 1);
2026 #endif /* ALTERNATE_SHEBANG */
2035 while (*d && !isSPACE(*d))
2039 #ifdef ARG_ZERO_IS_SCRIPT
2040 if (ipathend > ipath) {
2042 * HP-UX (at least) sets argv[0] to the script name,
2043 * which makes $^X incorrect. And Digital UNIX and Linux,
2044 * at least, set argv[0] to the basename of the Perl
2045 * interpreter. So, having found "#!", we'll set it right.
2047 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2048 assert(SvPOK(x) || SvGMAGICAL(x));
2049 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2050 sv_setpvn(x, ipath, ipathend - ipath);
2053 TAINT_NOT; /* $^X is always tainted, but that's OK */
2055 #endif /* ARG_ZERO_IS_SCRIPT */
2060 d = instr(s,"perl -");
2062 d = instr(s,"perl");
2063 #ifdef ALTERNATE_SHEBANG
2065 * If the ALTERNATE_SHEBANG on this system starts with a
2066 * character that can be part of a Perl expression, then if
2067 * we see it but not "perl", we're probably looking at the
2068 * start of Perl code, not a request to hand off to some
2069 * other interpreter. Similarly, if "perl" is there, but
2070 * not in the first 'word' of the line, we assume the line
2071 * contains the start of the Perl program.
2073 if (d && *s != '#') {
2075 while (*c && !strchr("; \t\r\n\f\v#", *c))
2078 d = Nullch; /* "perl" not in first word; ignore */
2080 *s = '#'; /* Don't try to parse shebang line */
2082 #endif /* ALTERNATE_SHEBANG */
2087 !instr(s,"indir") &&
2088 instr(PL_origargv[0],"perl"))
2094 while (s < PL_bufend && isSPACE(*s))
2096 if (s < PL_bufend) {
2097 Newz(899,newargv,PL_origargc+3,char*);
2099 while (s < PL_bufend && !isSPACE(*s))
2102 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2105 newargv = PL_origargv;
2107 execv(ipath, newargv);
2108 croak("Can't exec %s", ipath);
2111 U32 oldpdb = PL_perldb;
2112 bool oldn = PL_minus_n;
2113 bool oldp = PL_minus_p;
2115 while (*d && !isSPACE(*d)) d++;
2116 while (*d == ' ' || *d == '\t') d++;
2120 if (*d == 'M' || *d == 'm') {
2122 while (*d && !isSPACE(*d)) d++;
2123 croak("Too late for \"-%.*s\" option",
2126 d = moreswitches(d);
2128 if (PERLDB_LINE && !oldpdb ||
2129 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2130 /* if we have already added "LINE: while (<>) {",
2131 we must not do it again */
2133 sv_setpv(PL_linestr, "");
2134 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2135 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2136 PL_preambled = FALSE;
2138 (void)gv_fetchfile(PL_origfilename);
2145 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2147 PL_lex_state = LEX_FORMLINE;
2148 return yylex(PERL_YYLEX_PARAM);
2152 #ifdef PERL_STRICT_CR
2153 warn("Illegal character \\%03o (carriage return)", '\r');
2155 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2157 case ' ': case '\t': case '\f': case 013:
2162 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2164 while (s < d && *s != '\n')
2169 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2171 PL_lex_state = LEX_FORMLINE;
2172 return yylex(PERL_YYLEX_PARAM);
2181 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2186 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2189 if (strnEQ(s,"=>",2)) {
2190 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2191 OPERATOR('-'); /* unary minus */
2193 PL_last_uni = PL_oldbufptr;
2194 PL_last_lop_op = OP_FTEREAD; /* good enough */
2196 case 'r': FTST(OP_FTEREAD);
2197 case 'w': FTST(OP_FTEWRITE);
2198 case 'x': FTST(OP_FTEEXEC);
2199 case 'o': FTST(OP_FTEOWNED);
2200 case 'R': FTST(OP_FTRREAD);
2201 case 'W': FTST(OP_FTRWRITE);
2202 case 'X': FTST(OP_FTREXEC);
2203 case 'O': FTST(OP_FTROWNED);
2204 case 'e': FTST(OP_FTIS);
2205 case 'z': FTST(OP_FTZERO);
2206 case 's': FTST(OP_FTSIZE);
2207 case 'f': FTST(OP_FTFILE);
2208 case 'd': FTST(OP_FTDIR);
2209 case 'l': FTST(OP_FTLINK);
2210 case 'p': FTST(OP_FTPIPE);
2211 case 'S': FTST(OP_FTSOCK);
2212 case 'u': FTST(OP_FTSUID);
2213 case 'g': FTST(OP_FTSGID);
2214 case 'k': FTST(OP_FTSVTX);
2215 case 'b': FTST(OP_FTBLK);
2216 case 'c': FTST(OP_FTCHR);
2217 case 't': FTST(OP_FTTTY);
2218 case 'T': FTST(OP_FTTEXT);
2219 case 'B': FTST(OP_FTBINARY);
2220 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2221 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2222 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2224 croak("Unrecognized file test: -%c", (int)tmp);
2231 if (PL_expect == XOPERATOR)
2236 else if (*s == '>') {
2239 if (isIDFIRST_lazy(s)) {
2240 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2248 if (PL_expect == XOPERATOR)
2251 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2253 OPERATOR('-'); /* unary minus */
2260 if (PL_expect == XOPERATOR)
2265 if (PL_expect == XOPERATOR)
2268 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2274 if (PL_expect != XOPERATOR) {
2275 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2276 PL_expect = XOPERATOR;
2277 force_ident(PL_tokenbuf, '*');
2290 if (PL_expect == XOPERATOR) {
2294 PL_tokenbuf[0] = '%';
2295 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2296 if (!PL_tokenbuf[1]) {
2298 yyerror("Final % should be \\% or %name");
2301 PL_pending_ident = '%';
2323 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2324 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2329 if (PL_curcop->cop_line < PL_copline)
2330 PL_copline = PL_curcop->cop_line;
2341 if (PL_lex_brackets <= 0)
2342 yyerror("Unmatched right bracket");
2345 if (PL_lex_state == LEX_INTERPNORMAL) {
2346 if (PL_lex_brackets == 0) {
2347 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2348 PL_lex_state = LEX_INTERPEND;
2355 if (PL_lex_brackets > 100) {
2356 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2357 if (newlb != PL_lex_brackstack) {
2359 PL_lex_brackstack = newlb;
2362 switch (PL_expect) {
2364 if (PL_lex_formbrack) {
2368 if (PL_oldoldbufptr == PL_last_lop)
2369 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2371 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2372 OPERATOR(HASHBRACK);
2374 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2377 PL_tokenbuf[0] = '\0';
2378 if (d < PL_bufend && *d == '-') {
2379 PL_tokenbuf[0] = '-';
2381 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2384 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2385 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2387 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2390 char minus = (PL_tokenbuf[0] == '-');
2391 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2398 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2402 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2407 if (PL_oldoldbufptr == PL_last_lop)
2408 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2410 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2413 OPERATOR(HASHBRACK);
2414 /* This hack serves to disambiguate a pair of curlies
2415 * as being a block or an anon hash. Normally, expectation
2416 * determines that, but in cases where we're not in a
2417 * position to expect anything in particular (like inside
2418 * eval"") we have to resolve the ambiguity. This code
2419 * covers the case where the first term in the curlies is a
2420 * quoted string. Most other cases need to be explicitly
2421 * disambiguated by prepending a `+' before the opening
2422 * curly in order to force resolution as an anon hash.
2424 * XXX should probably propagate the outer expectation
2425 * into eval"" to rely less on this hack, but that could
2426 * potentially break current behavior of eval"".
2430 if (*s == '\'' || *s == '"' || *s == '`') {
2431 /* common case: get past first string, handling escapes */
2432 for (t++; t < PL_bufend && *t != *s;)
2433 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2437 else if (*s == 'q') {
2440 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2441 && !isALNUM(*t)))) {
2443 char open, close, term;
2446 while (t < PL_bufend && isSPACE(*t))
2450 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2454 for (t++; t < PL_bufend; t++) {
2455 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2457 else if (*t == open)
2461 for (t++; t < PL_bufend; t++) {
2462 if (*t == '\\' && t+1 < PL_bufend)
2464 else if (*t == close && --brackets <= 0)
2466 else if (*t == open)
2472 else if (isIDFIRST_lazy(s)) {
2473 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2475 while (t < PL_bufend && isSPACE(*t))
2477 /* if comma follows first term, call it an anon hash */
2478 /* XXX it could be a comma expression with loop modifiers */
2479 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2480 || (*t == '=' && t[1] == '>')))
2481 OPERATOR(HASHBRACK);
2482 if (PL_expect == XREF)
2483 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2485 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2491 yylval.ival = PL_curcop->cop_line;
2492 if (isSPACE(*s) || *s == '#')
2493 PL_copline = NOLINE; /* invalidate current command line number */
2498 if (PL_lex_brackets <= 0)
2499 yyerror("Unmatched right bracket");
2501 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2502 if (PL_lex_brackets < PL_lex_formbrack)
2503 PL_lex_formbrack = 0;
2504 if (PL_lex_state == LEX_INTERPNORMAL) {
2505 if (PL_lex_brackets == 0) {
2506 if (PL_lex_fakebrack) {
2507 PL_lex_state = LEX_INTERPEND;
2509 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2511 if (*s == '-' && s[1] == '>')
2512 PL_lex_state = LEX_INTERPENDMAYBE;
2513 else if (*s != '[' && *s != '{')
2514 PL_lex_state = LEX_INTERPEND;
2517 if (PL_lex_brackets < PL_lex_fakebrack) {
2519 PL_lex_fakebrack = 0;
2520 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2530 if (PL_expect == XOPERATOR) {
2531 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2532 PL_curcop->cop_line--;
2533 warner(WARN_SEMICOLON, PL_warn_nosemi);
2534 PL_curcop->cop_line++;
2539 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2541 PL_expect = XOPERATOR;
2542 force_ident(PL_tokenbuf, '&');
2546 yylval.ival = (OPpENTERSUB_AMPER<<8);
2565 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2566 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2568 if (PL_expect == XSTATE && isALPHA(tmp) &&
2569 (s == PL_linestart+1 || s[-2] == '\n') )
2571 if (PL_in_eval && !PL_rsfp) {
2576 if (strnEQ(s,"=cut",4)) {
2590 PL_doextract = TRUE;
2593 if (PL_lex_brackets < PL_lex_formbrack) {
2595 #ifdef PERL_STRICT_CR
2596 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2598 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2600 if (*t == '\n' || *t == '#') {
2618 if (PL_expect != XOPERATOR) {
2619 if (s[1] != '<' && !strchr(s,'>'))
2622 s = scan_heredoc(s);
2624 s = scan_inputsymbol(s);
2625 TERM(sublex_start());
2630 SHop(OP_LEFT_SHIFT);
2644 SHop(OP_RIGHT_SHIFT);
2653 if (PL_expect == XOPERATOR) {
2654 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2657 return ','; /* grandfather non-comma-format format */
2661 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2662 if (PL_expect == XOPERATOR)
2663 no_op("Array length", PL_bufptr);
2664 PL_tokenbuf[0] = '@';
2665 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2667 if (!PL_tokenbuf[1])
2669 PL_expect = XOPERATOR;
2670 PL_pending_ident = '#';
2674 if (PL_expect == XOPERATOR)
2675 no_op("Scalar", PL_bufptr);
2676 PL_tokenbuf[0] = '$';
2677 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2678 if (!PL_tokenbuf[1]) {
2680 yyerror("Final $ should be \\$ or $name");
2684 /* This kludge not intended to be bulletproof. */
2685 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2686 yylval.opval = newSVOP(OP_CONST, 0,
2687 newSViv((IV)PL_compiling.cop_arybase));
2688 yylval.opval->op_private = OPpCONST_ARYBASE;
2693 if (PL_lex_state == LEX_NORMAL)
2696 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2699 PL_tokenbuf[0] = '@';
2700 if (ckWARN(WARN_SYNTAX)) {
2702 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2705 PL_bufptr = skipspace(PL_bufptr);
2706 while (t < PL_bufend && *t != ']')
2709 "Multidimensional syntax %.*s not supported",
2710 (t - PL_bufptr) + 1, PL_bufptr);
2714 else if (*s == '{') {
2715 PL_tokenbuf[0] = '%';
2716 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2717 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2719 char tmpbuf[sizeof PL_tokenbuf];
2721 for (t++; isSPACE(*t); t++) ;
2722 if (isIDFIRST_lazy(t)) {
2723 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2724 for (; isSPACE(*t); t++) ;
2725 if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
2727 "You need to quote \"%s\"", tmpbuf);
2733 PL_expect = XOPERATOR;
2734 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2735 bool islop = (PL_last_lop == PL_oldoldbufptr);
2736 if (!islop || PL_last_lop_op == OP_GREPSTART)
2737 PL_expect = XOPERATOR;
2738 else if (strchr("$@\"'`q", *s))
2739 PL_expect = XTERM; /* e.g. print $fh "foo" */
2740 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2741 PL_expect = XTERM; /* e.g. print $fh &sub */
2742 else if (isIDFIRST_lazy(s)) {
2743 char tmpbuf[sizeof PL_tokenbuf];
2744 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2745 if (tmp = keyword(tmpbuf, len)) {
2746 /* binary operators exclude handle interpretations */
2758 PL_expect = XTERM; /* e.g. print $fh length() */
2763 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2764 if (gv && GvCVu(gv))
2765 PL_expect = XTERM; /* e.g. print $fh subr() */
2768 else if (isDIGIT(*s))
2769 PL_expect = XTERM; /* e.g. print $fh 3 */
2770 else if (*s == '.' && isDIGIT(s[1]))
2771 PL_expect = XTERM; /* e.g. print $fh .3 */
2772 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2773 PL_expect = XTERM; /* e.g. print $fh -1 */
2774 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2775 PL_expect = XTERM; /* print $fh <<"EOF" */
2777 PL_pending_ident = '$';
2781 if (PL_expect == XOPERATOR)
2783 PL_tokenbuf[0] = '@';
2784 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2785 if (!PL_tokenbuf[1]) {
2787 yyerror("Final @ should be \\@ or @name");
2790 if (PL_lex_state == LEX_NORMAL)
2792 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2794 PL_tokenbuf[0] = '%';
2796 /* Warn about @ where they meant $. */
2797 if (ckWARN(WARN_SYNTAX)) {
2798 if (*s == '[' || *s == '{') {
2800 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2802 if (*t == '}' || *t == ']') {
2804 PL_bufptr = skipspace(PL_bufptr);
2806 "Scalar value %.*s better written as $%.*s",
2807 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2812 PL_pending_ident = '@';
2815 case '/': /* may either be division or pattern */
2816 case '?': /* may either be conditional or pattern */
2817 if (PL_expect != XOPERATOR) {
2818 /* Disable warning on "study /blah/" */
2819 if (PL_oldoldbufptr == PL_last_uni
2820 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2821 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2823 s = scan_pat(s,OP_MATCH);
2824 TERM(sublex_start());
2832 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2833 #ifdef PERL_STRICT_CR
2836 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2838 && (s == PL_linestart || s[-1] == '\n') )
2840 PL_lex_formbrack = 0;
2844 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2850 yylval.ival = OPf_SPECIAL;
2856 if (PL_expect != XOPERATOR)
2861 case '0': case '1': case '2': case '3': case '4':
2862 case '5': case '6': case '7': case '8': case '9':
2864 if (PL_expect == XOPERATOR)
2870 if (PL_expect == XOPERATOR) {
2871 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2874 return ','; /* grandfather non-comma-format format */
2880 missingterm((char*)0);
2881 yylval.ival = OP_CONST;
2882 TERM(sublex_start());
2886 if (PL_expect == XOPERATOR) {
2887 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2890 return ','; /* grandfather non-comma-format format */
2896 missingterm((char*)0);
2897 yylval.ival = OP_CONST;
2898 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2899 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2900 yylval.ival = OP_STRINGIFY;
2904 TERM(sublex_start());
2908 if (PL_expect == XOPERATOR)
2909 no_op("Backticks",s);
2911 missingterm((char*)0);
2912 yylval.ival = OP_BACKTICK;
2914 TERM(sublex_start());
2918 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2919 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2921 if (PL_expect == XOPERATOR)
2922 no_op("Backslash",s);
2926 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2965 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2967 /* Some keywords can be followed by any delimiter, including ':' */
2968 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2969 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2970 (PL_tokenbuf[0] == 'q' &&
2971 strchr("qwxr", PL_tokenbuf[1]))));
2973 /* x::* is just a word, unless x is "CORE" */
2974 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2978 while (d < PL_bufend && isSPACE(*d))
2979 d++; /* no comments skipped here, or s### is misparsed */
2981 /* Is this a label? */
2982 if (!tmp && PL_expect == XSTATE
2983 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2985 yylval.pval = savepv(PL_tokenbuf);
2990 /* Check for keywords */
2991 tmp = keyword(PL_tokenbuf, len);
2993 /* Is this a word before a => operator? */
2994 if (strnEQ(d,"=>",2)) {
2996 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2997 yylval.opval->op_private = OPpCONST_BARE;
3001 if (tmp < 0) { /* second-class keyword? */
3002 GV *ogv = Nullgv; /* override (winner) */
3003 GV *hgv = Nullgv; /* hidden (loser) */
3004 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3006 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3009 if (GvIMPORTED_CV(gv))
3011 else if (! CvMETHOD(cv))
3015 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3016 (gv = *gvp) != (GV*)&PL_sv_undef &&
3017 GvCVu(gv) && GvIMPORTED_CV(gv))
3023 tmp = 0; /* overridden by import or by GLOBAL */
3026 && -tmp==KEY_lock /* XXX generalizable kludge */
3027 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3029 tmp = 0; /* any sub overrides "weak" keyword */
3031 else { /* no override */
3035 if (ckWARN(WARN_AMBIGUOUS) && hgv
3036 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3037 warner(WARN_AMBIGUOUS,
3038 "Ambiguous call resolved as CORE::%s(), %s",
3039 GvENAME(hgv), "qualify as such or use &");
3046 default: /* not a keyword */
3049 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3051 /* Get the rest if it looks like a package qualifier */
3053 if (*s == '\'' || *s == ':' && s[1] == ':') {
3055 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3058 croak("Bad name after %s%s", PL_tokenbuf,
3059 *s == '\'' ? "'" : "::");
3063 if (PL_expect == XOPERATOR) {
3064 if (PL_bufptr == PL_linestart) {
3065 PL_curcop->cop_line--;
3066 warner(WARN_SEMICOLON, PL_warn_nosemi);
3067 PL_curcop->cop_line++;
3070 no_op("Bareword",s);
3073 /* Look for a subroutine with this name in current package,
3074 unless name is "Foo::", in which case Foo is a bearword
3075 (and a package name). */
3078 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3080 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3082 "Bareword \"%s\" refers to nonexistent package",
3085 PL_tokenbuf[len] = '\0';
3092 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3095 /* if we saw a global override before, get the right name */
3098 sv = newSVpv("CORE::GLOBAL::",14);
3099 sv_catpv(sv,PL_tokenbuf);
3102 sv = newSVpv(PL_tokenbuf,0);
3104 /* Presume this is going to be a bareword of some sort. */
3107 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3108 yylval.opval->op_private = OPpCONST_BARE;
3110 /* And if "Foo::", then that's what it certainly is. */
3115 /* See if it's the indirect object for a list operator. */
3117 if (PL_oldoldbufptr &&
3118 PL_oldoldbufptr < PL_bufptr &&
3119 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3120 /* NO SKIPSPACE BEFORE HERE! */
3122 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3123 || (PL_last_lop_op == OP_ENTERSUB
3125 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3127 bool immediate_paren = *s == '(';
3129 /* (Now we can afford to cross potential line boundary.) */
3132 /* Two barewords in a row may indicate method call. */
3134 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3137 /* If not a declared subroutine, it's an indirect object. */
3138 /* (But it's an indir obj regardless for sort.) */
3140 if ((PL_last_lop_op == OP_SORT ||
3141 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3142 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3143 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3148 /* If followed by a paren, it's certainly a subroutine. */
3150 PL_expect = XOPERATOR;
3154 if (gv && GvCVu(gv)) {
3156 if ((cv = GvCV(gv)) && SvPOK(cv))
3157 PL_last_proto = SvPV((SV*)cv, PL_na);
3158 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3159 if (*d == ')' && (sv = cv_const_sv(cv))) {
3164 PL_nextval[PL_nexttoke].opval = yylval.opval;
3165 PL_expect = XOPERATOR;
3168 PL_last_lop_op = OP_ENTERSUB;
3172 /* If followed by var or block, call it a method (unless sub) */
3174 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3175 PL_last_lop = PL_oldbufptr;
3176 PL_last_lop_op = OP_METHOD;
3180 /* If followed by a bareword, see if it looks like indir obj. */
3182 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3185 /* Not a method, so call it a subroutine (if defined) */
3187 if (gv && GvCVu(gv)) {
3189 if (lastchar == '-')
3190 warn("Ambiguous use of -%s resolved as -&%s()",
3191 PL_tokenbuf, PL_tokenbuf);
3192 PL_last_lop = PL_oldbufptr;
3193 PL_last_lop_op = OP_ENTERSUB;
3194 /* Check for a constant sub */
3196 if ((sv = cv_const_sv(cv))) {
3198 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3199 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3200 yylval.opval->op_private = 0;
3204 /* Resolve to GV now. */
3205 op_free(yylval.opval);
3206 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3207 PL_last_lop_op = OP_ENTERSUB;
3208 /* Is there a prototype? */
3211 PL_last_proto = SvPV((SV*)cv, len);
3214 if (strEQ(PL_last_proto, "$"))
3216 if (*PL_last_proto == '&' && *s == '{') {
3217 sv_setpv(PL_subname,"__ANON__");
3221 PL_last_proto = NULL;
3222 PL_nextval[PL_nexttoke].opval = yylval.opval;
3228 if (PL_hints & HINT_STRICT_SUBS &&
3231 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3232 PL_last_lop_op != OP_ACCEPT &&
3233 PL_last_lop_op != OP_PIPE_OP &&
3234 PL_last_lop_op != OP_SOCKPAIR &&
3235 !(PL_last_lop_op == OP_ENTERSUB
3237 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3240 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3245 /* Call it a bare word */
3248 if (ckWARN(WARN_RESERVED)) {
3249 if (lastchar != '-') {
3250 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3252 warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
3257 if (lastchar && strchr("*%&", lastchar)) {
3258 warn("Operator or semicolon missing before %c%s",
3259 lastchar, PL_tokenbuf);
3260 warn("Ambiguous use of %c resolved as operator %c",
3261 lastchar, lastchar);
3267 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3268 newSVsv(GvSV(PL_curcop->cop_filegv)));
3272 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3273 newSVpvf("%ld", (long)PL_curcop->cop_line));
3276 case KEY___PACKAGE__:
3277 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3279 ? newSVsv(PL_curstname)
3288 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3289 char *pname = "main";
3290 if (PL_tokenbuf[2] == 'D')
3291 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3292 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3295 GvIOp(gv) = newIO();
3296 IoIFP(GvIOp(gv)) = PL_rsfp;
3297 #if defined(HAS_FCNTL) && defined(F_SETFD)
3299 int fd = PerlIO_fileno(PL_rsfp);
3300 fcntl(fd,F_SETFD,fd >= 3);
3303 /* Mark this internal pseudo-handle as clean */
3304 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3306 IoTYPE(GvIOp(gv)) = '|';
3307 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3308 IoTYPE(GvIOp(gv)) = '-';
3310 IoTYPE(GvIOp(gv)) = '<';
3321 if (PL_expect == XSTATE) {
3328 if (*s == ':' && s[1] == ':') {
3331 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3332 tmp = keyword(PL_tokenbuf, len);
3346 LOP(OP_ACCEPT,XTERM);
3352 LOP(OP_ATAN2,XTERM);
3361 LOP(OP_BLESS,XTERM);
3370 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3387 if (!PL_cryptseen++)
3390 LOP(OP_CRYPT,XTERM);
3393 if (ckWARN(WARN_OCTAL)) {
3394 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3395 if (*d != '0' && isDIGIT(*d))
3396 yywarn("chmod: mode argument is missing initial 0");
3398 LOP(OP_CHMOD,XTERM);
3401 LOP(OP_CHOWN,XTERM);
3404 LOP(OP_CONNECT,XTERM);
3420 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3424 PL_hints |= HINT_BLOCK_SCOPE;
3434 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3435 LOP(OP_DBMOPEN,XTERM);
3441 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3448 yylval.ival = PL_curcop->cop_line;
3462 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3463 UNIBRACK(OP_ENTEREVAL);
3478 case KEY_endhostent:
3484 case KEY_endservent:
3487 case KEY_endprotoent:
3498 yylval.ival = PL_curcop->cop_line;
3500 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3502 if ((PL_bufend - p) >= 3 &&
3503 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3506 if (isIDFIRST_lazy(p))
3507 croak("Missing $ on loop variable");
3512 LOP(OP_FORMLINE,XTERM);
3518 LOP(OP_FCNTL,XTERM);
3524 LOP(OP_FLOCK,XTERM);
3533 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3536 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3551 case KEY_getpriority:
3552 LOP(OP_GETPRIORITY,XTERM);
3554 case KEY_getprotobyname:
3557 case KEY_getprotobynumber:
3558 LOP(OP_GPBYNUMBER,XTERM);
3560 case KEY_getprotoent:
3572 case KEY_getpeername:
3573 UNI(OP_GETPEERNAME);
3575 case KEY_gethostbyname:
3578 case KEY_gethostbyaddr:
3579 LOP(OP_GHBYADDR,XTERM);
3581 case KEY_gethostent:
3584 case KEY_getnetbyname:
3587 case KEY_getnetbyaddr:
3588 LOP(OP_GNBYADDR,XTERM);
3593 case KEY_getservbyname:
3594 LOP(OP_GSBYNAME,XTERM);
3596 case KEY_getservbyport:
3597 LOP(OP_GSBYPORT,XTERM);
3599 case KEY_getservent:
3602 case KEY_getsockname:
3603 UNI(OP_GETSOCKNAME);
3605 case KEY_getsockopt:
3606 LOP(OP_GSOCKOPT,XTERM);
3628 yylval.ival = PL_curcop->cop_line;
3632 LOP(OP_INDEX,XTERM);
3638 LOP(OP_IOCTL,XTERM);
3650 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3681 LOP(OP_LISTEN,XTERM);
3690 s = scan_pat(s,OP_MATCH);
3691 TERM(sublex_start());
3694 LOP(OP_MAPSTART, XREF);
3697 LOP(OP_MKDIR,XTERM);
3700 LOP(OP_MSGCTL,XTERM);
3703 LOP(OP_MSGGET,XTERM);
3706 LOP(OP_MSGRCV,XTERM);
3709 LOP(OP_MSGSND,XTERM);
3714 if (isIDFIRST_lazy(s)) {
3715 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3716 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3717 if (!PL_in_my_stash) {
3720 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3727 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3734 if (PL_expect != XSTATE)
3735 yyerror("\"no\" not allowed in expression");
3736 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3737 s = force_version(s);
3746 if (isIDFIRST_lazy(s)) {
3748 for (d = s; isALNUM_lazy(d); d++) ;
3750 if (strchr("|&*+-=!?:.", *t))
3751 warn("Precedence problem: open %.*s should be open(%.*s)",
3757 yylval.ival = OP_OR;
3767 LOP(OP_OPEN_DIR,XTERM);
3770 checkcomma(s,PL_tokenbuf,"filehandle");
3774 checkcomma(s,PL_tokenbuf,"filehandle");
3793 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3797 LOP(OP_PIPE_OP,XTERM);
3802 missingterm((char*)0);
3803 yylval.ival = OP_CONST;
3804 TERM(sublex_start());
3812 missingterm((char*)0);
3813 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3814 d = SvPV_force(PL_lex_stuff, len);
3815 for (; len; --len, ++d) {
3818 "Possible attempt to separate words with commas");
3823 "Possible attempt to put comments in qw() list");
3829 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3830 PL_lex_stuff = Nullsv;
3833 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3836 yylval.ival = OP_SPLIT;
3840 PL_last_lop = PL_oldbufptr;
3841 PL_last_lop_op = OP_SPLIT;
3847 missingterm((char*)0);
3848 yylval.ival = OP_STRINGIFY;
3849 if (SvIVX(PL_lex_stuff) == '\'')
3850 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3851 TERM(sublex_start());
3854 s = scan_pat(s,OP_QR);
3855 TERM(sublex_start());
3860 missingterm((char*)0);
3861 yylval.ival = OP_BACKTICK;
3863 TERM(sublex_start());
3869 *PL_tokenbuf = '\0';
3870 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3871 if (isIDFIRST_lazy(PL_tokenbuf))
3872 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3874 yyerror("<> should be quotes");
3881 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3885 LOP(OP_RENAME,XTERM);
3894 LOP(OP_RINDEX,XTERM);
3917 LOP(OP_REVERSE,XTERM);
3928 TERM(sublex_start());
3930 TOKEN(1); /* force error */
3939 LOP(OP_SELECT,XTERM);
3945 LOP(OP_SEMCTL,XTERM);
3948 LOP(OP_SEMGET,XTERM);
3951 LOP(OP_SEMOP,XTERM);
3957 LOP(OP_SETPGRP,XTERM);
3959 case KEY_setpriority:
3960 LOP(OP_SETPRIORITY,XTERM);
3962 case KEY_sethostent:
3968 case KEY_setservent:
3971 case KEY_setprotoent:
3981 LOP(OP_SEEKDIR,XTERM);
3983 case KEY_setsockopt:
3984 LOP(OP_SSOCKOPT,XTERM);
3990 LOP(OP_SHMCTL,XTERM);
3993 LOP(OP_SHMGET,XTERM);
3996 LOP(OP_SHMREAD,XTERM);
3999 LOP(OP_SHMWRITE,XTERM);
4002 LOP(OP_SHUTDOWN,XTERM);
4011 LOP(OP_SOCKET,XTERM);
4013 case KEY_socketpair:
4014 LOP(OP_SOCKPAIR,XTERM);
4017 checkcomma(s,PL_tokenbuf,"subroutine name");
4019 if (*s == ';' || *s == ')') /* probably a close */
4020 croak("sort is now a reserved word");
4022 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4026 LOP(OP_SPLIT,XTERM);
4029 LOP(OP_SPRINTF,XTERM);
4032 LOP(OP_SPLICE,XTERM);
4048 LOP(OP_SUBSTR,XTERM);
4055 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4056 char tmpbuf[sizeof PL_tokenbuf];
4058 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4059 if (strchr(tmpbuf, ':'))
4060 sv_setpv(PL_subname, tmpbuf);
4062 sv_setsv(PL_subname,PL_curstname);
4063 sv_catpvn(PL_subname,"::",2);
4064 sv_catpvn(PL_subname,tmpbuf,len);
4066 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4070 PL_expect = XTERMBLOCK;
4071 sv_setpv(PL_subname,"?");
4074 if (tmp == KEY_format) {
4077 PL_lex_formbrack = PL_lex_brackets + 1;
4081 /* Look for a prototype */
4088 SvREFCNT_dec(PL_lex_stuff);
4089 PL_lex_stuff = Nullsv;
4090 croak("Prototype not terminated");
4093 d = SvPVX(PL_lex_stuff);
4095 for (p = d; *p; ++p) {
4100 SvCUR(PL_lex_stuff) = tmp;
4103 PL_nextval[1] = PL_nextval[0];
4104 PL_nexttype[1] = PL_nexttype[0];
4105 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4106 PL_nexttype[0] = THING;
4107 if (PL_nexttoke == 1) {
4108 PL_lex_defer = PL_lex_state;
4109 PL_lex_expect = PL_expect;
4110 PL_lex_state = LEX_KNOWNEXT;
4112 PL_lex_stuff = Nullsv;
4115 if (*SvPV(PL_subname,PL_na) == '?') {
4116 sv_setpv(PL_subname,"__ANON__");
4123 LOP(OP_SYSTEM,XREF);
4126 LOP(OP_SYMLINK,XTERM);
4129 LOP(OP_SYSCALL,XTERM);
4132 LOP(OP_SYSOPEN,XTERM);
4135 LOP(OP_SYSSEEK,XTERM);
4138 LOP(OP_SYSREAD,XTERM);
4141 LOP(OP_SYSWRITE,XTERM);
4145 TERM(sublex_start());
4166 LOP(OP_TRUNCATE,XTERM);
4178 yylval.ival = PL_curcop->cop_line;
4182 yylval.ival = PL_curcop->cop_line;
4186 LOP(OP_UNLINK,XTERM);
4192 LOP(OP_UNPACK,XTERM);
4195 LOP(OP_UTIME,XTERM);
4198 if (ckWARN(WARN_OCTAL)) {
4199 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4200 if (*d != '0' && isDIGIT(*d))
4201 yywarn("umask: argument is missing initial 0");
4206 LOP(OP_UNSHIFT,XTERM);
4209 if (PL_expect != XSTATE)
4210 yyerror("\"use\" not allowed in expression");
4213 s = force_version(s);
4214 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4215 PL_nextval[PL_nexttoke].opval = Nullop;
4220 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4221 s = force_version(s);
4234 yylval.ival = PL_curcop->cop_line;
4238 PL_hints |= HINT_BLOCK_SCOPE;
4245 LOP(OP_WAITPID,XTERM);
4253 static char ctl_l[2];
4255 if (ctl_l[0] == '\0')
4256 ctl_l[0] = toCTRL('L');
4257 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4260 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4265 if (PL_expect == XOPERATOR)
4271 yylval.ival = OP_XOR;
4276 TERM(sublex_start());
4282 keyword(register char *d, I32 len)
4287 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4288 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4289 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4290 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4291 if (strEQ(d,"__END__")) return KEY___END__;
4295 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4300 if (strEQ(d,"and")) return -KEY_and;
4301 if (strEQ(d,"abs")) return -KEY_abs;
4304 if (strEQ(d,"alarm")) return -KEY_alarm;
4305 if (strEQ(d,"atan2")) return -KEY_atan2;
4308 if (strEQ(d,"accept")) return -KEY_accept;
4313 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4316 if (strEQ(d,"bless")) return -KEY_bless;
4317 if (strEQ(d,"bind")) return -KEY_bind;
4318 if (strEQ(d,"binmode")) return -KEY_binmode;
4321 if (strEQ(d,"CORE")) return -KEY_CORE;
4326 if (strEQ(d,"cmp")) return -KEY_cmp;
4327 if (strEQ(d,"chr")) return -KEY_chr;
4328 if (strEQ(d,"cos")) return -KEY_cos;
4331 if (strEQ(d,"chop")) return KEY_chop;
4334 if (strEQ(d,"close")) return -KEY_close;
4335 if (strEQ(d,"chdir")) return -KEY_chdir;
4336 if (strEQ(d,"chomp")) return KEY_chomp;
4337 if (strEQ(d,"chmod")) return -KEY_chmod;
4338 if (strEQ(d,"chown")) return -KEY_chown;
4339 if (strEQ(d,"crypt")) return -KEY_crypt;
4342 if (strEQ(d,"chroot")) return -KEY_chroot;
4343 if (strEQ(d,"caller")) return -KEY_caller;
4346 if (strEQ(d,"connect")) return -KEY_connect;
4349 if (strEQ(d,"closedir")) return -KEY_closedir;
4350 if (strEQ(d,"continue")) return -KEY_continue;
4355 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4360 if (strEQ(d,"do")) return KEY_do;
4363 if (strEQ(d,"die")) return -KEY_die;
4366 if (strEQ(d,"dump")) return -KEY_dump;
4369 if (strEQ(d,"delete")) return KEY_delete;
4372 if (strEQ(d,"defined")) return KEY_defined;
4373 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4376 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4381 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4382 if (strEQ(d,"END")) return KEY_END;
4387 if (strEQ(d,"eq")) return -KEY_eq;
4390 if (strEQ(d,"eof")) return -KEY_eof;
4391 if (strEQ(d,"exp")) return -KEY_exp;
4394 if (strEQ(d,"else")) return KEY_else;
4395 if (strEQ(d,"exit")) return -KEY_exit;
4396 if (strEQ(d,"eval")) return KEY_eval;
4397 if (strEQ(d,"exec")) return -KEY_exec;
4398 if (strEQ(d,"each")) return KEY_each;
4401 if (strEQ(d,"elsif")) return KEY_elsif;
4404 if (strEQ(d,"exists")) return KEY_exists;
4405 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4408 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4409 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4412 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4415 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4416 if (strEQ(d,"endservent")) return -KEY_endservent;
4419 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4426 if (strEQ(d,"for")) return KEY_for;
4429 if (strEQ(d,"fork")) return -KEY_fork;
4432 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4433 if (strEQ(d,"flock")) return -KEY_flock;
4436 if (strEQ(d,"format")) return KEY_format;
4437 if (strEQ(d,"fileno")) return -KEY_fileno;
4440 if (strEQ(d,"foreach")) return KEY_foreach;
4443 if (strEQ(d,"formline")) return -KEY_formline;
4449 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4450 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4454 if (strnEQ(d,"get",3)) {
4459 if (strEQ(d,"ppid")) return -KEY_getppid;
4460 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4463 if (strEQ(d,"pwent")) return -KEY_getpwent;
4464 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4465 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4468 if (strEQ(d,"peername")) return -KEY_getpeername;
4469 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4470 if (strEQ(d,"priority")) return -KEY_getpriority;
4473 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4476 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4480 else if (*d == 'h') {
4481 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4482 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4483 if (strEQ(d,"hostent")) return -KEY_gethostent;
4485 else if (*d == 'n') {
4486 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4487 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4488 if (strEQ(d,"netent")) return -KEY_getnetent;
4490 else if (*d == 's') {
4491 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4492 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4493 if (strEQ(d,"servent")) return -KEY_getservent;
4494 if (strEQ(d,"sockname")) return -KEY_getsockname;
4495 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4497 else if (*d == 'g') {
4498 if (strEQ(d,"grent")) return -KEY_getgrent;
4499 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4500 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4502 else if (*d == 'l') {
4503 if (strEQ(d,"login")) return -KEY_getlogin;
4505 else if (strEQ(d,"c")) return -KEY_getc;
4510 if (strEQ(d,"gt")) return -KEY_gt;
4511 if (strEQ(d,"ge")) return -KEY_ge;
4514 if (strEQ(d,"grep")) return KEY_grep;
4515 if (strEQ(d,"goto")) return KEY_goto;
4516 if (strEQ(d,"glob")) return KEY_glob;
4519 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4524 if (strEQ(d,"hex")) return -KEY_hex;
4527 if (strEQ(d,"INIT")) return KEY_INIT;
4532 if (strEQ(d,"if")) return KEY_if;
4535 if (strEQ(d,"int")) return -KEY_int;
4538 if (strEQ(d,"index")) return -KEY_index;
4539 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4544 if (strEQ(d,"join")) return -KEY_join;
4548 if (strEQ(d,"keys")) return KEY_keys;
4549 if (strEQ(d,"kill")) return -KEY_kill;
4554 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4555 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4561 if (strEQ(d,"lt")) return -KEY_lt;
4562 if (strEQ(d,"le")) return -KEY_le;
4563 if (strEQ(d,"lc")) return -KEY_lc;
4566 if (strEQ(d,"log")) return -KEY_log;
4569 if (strEQ(d,"last")) return KEY_last;
4570 if (strEQ(d,"link")) return -KEY_link;
4571 if (strEQ(d,"lock")) return -KEY_lock;
4574 if (strEQ(d,"local")) return KEY_local;
4575 if (strEQ(d,"lstat")) return -KEY_lstat;
4578 if (strEQ(d,"length")) return -KEY_length;
4579 if (strEQ(d,"listen")) return -KEY_listen;
4582 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4585 if (strEQ(d,"localtime")) return -KEY_localtime;
4591 case 1: return KEY_m;
4593 if (strEQ(d,"my")) return KEY_my;
4596 if (strEQ(d,"map")) return KEY_map;
4599 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4602 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4603 if (strEQ(d,"msgget")) return -KEY_msgget;
4604 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4605 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4610 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4613 if (strEQ(d,"next")) return KEY_next;
4614 if (strEQ(d,"ne")) return -KEY_ne;
4615 if (strEQ(d,"not")) return -KEY_not;
4616 if (strEQ(d,"no")) return KEY_no;
4621 if (strEQ(d,"or")) return -KEY_or;
4624 if (strEQ(d,"ord")) return -KEY_ord;
4625 if (strEQ(d,"oct")) return -KEY_oct;
4626 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4630 if (strEQ(d,"open")) return -KEY_open;
4633 if (strEQ(d,"opendir")) return -KEY_opendir;
4640 if (strEQ(d,"pop")) return KEY_pop;
4641 if (strEQ(d,"pos")) return KEY_pos;
4644 if (strEQ(d,"push")) return KEY_push;
4645 if (strEQ(d,"pack")) return -KEY_pack;
4646 if (strEQ(d,"pipe")) return -KEY_pipe;
4649 if (strEQ(d,"print")) return KEY_print;
4652 if (strEQ(d,"printf")) return KEY_printf;
4655 if (strEQ(d,"package")) return KEY_package;
4658 if (strEQ(d,"prototype")) return KEY_prototype;
4663 if (strEQ(d,"q")) return KEY_q;
4664 if (strEQ(d,"qr")) return KEY_qr;
4665 if (strEQ(d,"qq")) return KEY_qq;
4666 if (strEQ(d,"qw")) return KEY_qw;
4667 if (strEQ(d,"qx")) return KEY_qx;
4669 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4674 if (strEQ(d,"ref")) return -KEY_ref;
4677 if (strEQ(d,"read")) return -KEY_read;
4678 if (strEQ(d,"rand")) return -KEY_rand;
4679 if (strEQ(d,"recv")) return -KEY_recv;
4680 if (strEQ(d,"redo")) return KEY_redo;
4683 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4684 if (strEQ(d,"reset")) return -KEY_reset;
4687 if (strEQ(d,"return")) return KEY_return;
4688 if (strEQ(d,"rename")) return -KEY_rename;
4689 if (strEQ(d,"rindex")) return -KEY_rindex;
4692 if (strEQ(d,"require")) return -KEY_require;
4693 if (strEQ(d,"reverse")) return -KEY_reverse;
4694 if (strEQ(d,"readdir")) return -KEY_readdir;
4697 if (strEQ(d,"readlink")) return -KEY_readlink;
4698 if (strEQ(d,"readline")) return -KEY_readline;
4699 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4702 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4708 case 0: return KEY_s;
4710 if (strEQ(d,"scalar")) return KEY_scalar;
4715 if (strEQ(d,"seek")) return -KEY_seek;
4716 if (strEQ(d,"send")) return -KEY_send;
4719 if (strEQ(d,"semop")) return -KEY_semop;
4722 if (strEQ(d,"select")) return -KEY_select;
4723 if (strEQ(d,"semctl")) return -KEY_semctl;
4724 if (strEQ(d,"semget")) return -KEY_semget;
4727 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4728 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4731 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4732 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4735 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4738 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4739 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4740 if (strEQ(d,"setservent")) return -KEY_setservent;
4743 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4744 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4751 if (strEQ(d,"shift")) return KEY_shift;
4754 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4755 if (strEQ(d,"shmget")) return -KEY_shmget;
4758 if (strEQ(d,"shmread")) return -KEY_shmread;
4761 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4762 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4767 if (strEQ(d,"sin")) return -KEY_sin;
4770 if (strEQ(d,"sleep")) return -KEY_sleep;
4773 if (strEQ(d,"sort")) return KEY_sort;
4774 if (strEQ(d,"socket")) return -KEY_socket;
4775 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4778 if (strEQ(d,"split")) return KEY_split;
4779 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4780 if (strEQ(d,"splice")) return KEY_splice;
4783 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4786 if (strEQ(d,"srand")) return -KEY_srand;
4789 if (strEQ(d,"stat")) return -KEY_stat;
4790 if (strEQ(d,"study")) return KEY_study;
4793 if (strEQ(d,"substr")) return -KEY_substr;
4794 if (strEQ(d,"sub")) return KEY_sub;
4799 if (strEQ(d,"system")) return -KEY_system;
4802 if (strEQ(d,"symlink")) return -KEY_symlink;
4803 if (strEQ(d,"syscall")) return -KEY_syscall;
4804 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4805 if (strEQ(d,"sysread")) return -KEY_sysread;
4806 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4809 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4818 if (strEQ(d,"tr")) return KEY_tr;
4821 if (strEQ(d,"tie")) return KEY_tie;
4824 if (strEQ(d,"tell")) return -KEY_tell;
4825 if (strEQ(d,"tied")) return KEY_tied;
4826 if (strEQ(d,"time")) return -KEY_time;
4829 if (strEQ(d,"times")) return -KEY_times;
4832 if (strEQ(d,"telldir")) return -KEY_telldir;
4835 if (strEQ(d,"truncate")) return -KEY_truncate;
4842 if (strEQ(d,"uc")) return -KEY_uc;
4845 if (strEQ(d,"use")) return KEY_use;
4848 if (strEQ(d,"undef")) return KEY_undef;
4849 if (strEQ(d,"until")) return KEY_until;
4850 if (strEQ(d,"untie")) return KEY_untie;
4851 if (strEQ(d,"utime")) return -KEY_utime;
4852 if (strEQ(d,"umask")) return -KEY_umask;
4855 if (strEQ(d,"unless")) return KEY_unless;
4856 if (strEQ(d,"unpack")) return -KEY_unpack;
4857 if (strEQ(d,"unlink")) return -KEY_unlink;
4860 if (strEQ(d,"unshift")) return KEY_unshift;
4861 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4866 if (strEQ(d,"values")) return -KEY_values;
4867 if (strEQ(d,"vec")) return -KEY_vec;
4872 if (strEQ(d,"warn")) return -KEY_warn;
4873 if (strEQ(d,"wait")) return -KEY_wait;
4876 if (strEQ(d,"while")) return KEY_while;
4877 if (strEQ(d,"write")) return -KEY_write;
4880 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4883 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4888 if (len == 1) return -KEY_x;
4889 if (strEQ(d,"xor")) return -KEY_xor;
4892 if (len == 1) return KEY_y;
4901 checkcomma(register char *s, char *name, char *what)
4905 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4906 dTHR; /* only for ckWARN */
4907 if (ckWARN(WARN_SYNTAX)) {
4909 for (w = s+2; *w && level; w++) {
4916 for (; *w && isSPACE(*w); w++) ;
4917 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4918 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4921 while (s < PL_bufend && isSPACE(*s))
4925 while (s < PL_bufend && isSPACE(*s))
4927 if (isIDFIRST_lazy(s)) {
4929 while (isALNUM_lazy(s))
4931 while (s < PL_bufend && isSPACE(*s))
4936 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4940 croak("No comma allowed after %s", what);
4946 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4949 HV *table = GvHV(PL_hintgv); /* ^H */
4952 bool oldcatch = CATCH_GET;
4958 yyerror("%^H is not defined");
4961 cvp = hv_fetch(table, key, strlen(key), FALSE);
4962 if (!cvp || !SvOK(*cvp)) {
4963 sprintf(buf,"$^H{%s} is not defined", key);
4967 sv_2mortal(sv); /* Parent created it permanently */
4970 pv = sv_2mortal(newSVpv(s, len));
4972 typesv = sv_2mortal(newSVpv(type, 0));
4974 typesv = &PL_sv_undef;
4976 Zero(&myop, 1, BINOP);
4977 myop.op_last = (OP *) &myop;
4978 myop.op_next = Nullop;
4979 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4981 PUSHSTACKi(PERLSI_OVERLOAD);
4984 PL_op = (OP *) &myop;
4985 if (PERLDB_SUB && PL_curstash != PL_debstash)
4986 PL_op->op_private |= OPpENTERSUB_DB;
4997 if (PL_op = pp_entersub(ARGS))
5004 CATCH_SET(oldcatch);
5008 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5011 return SvREFCNT_inc(res);
5015 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5017 register char *d = dest;
5018 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5021 croak(ident_too_long);
5022 if (isALNUM(*s)) /* UTF handled below */
5024 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5029 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5033 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5034 char *t = s + UTF8SKIP(s);
5035 while (*t & 0x80 && is_utf8_mark((U8*)t))
5037 if (d + (t - s) > e)
5038 croak(ident_too_long);
5039 Copy(s, d, t - s, char);
5052 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5059 if (PL_lex_brackets == 0)
5060 PL_lex_fakebrack = 0;
5064 e = d + destlen - 3; /* two-character token, ending NUL */
5066 while (isDIGIT(*s)) {
5068 croak(ident_too_long);
5075 croak(ident_too_long);
5076 if (isALNUM(*s)) /* UTF handled below */
5078 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5083 else if (*s == ':' && s[1] == ':') {
5087 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5088 char *t = s + UTF8SKIP(s);
5089 while (*t & 0x80 && is_utf8_mark((U8*)t))
5091 if (d + (t - s) > e)
5092 croak(ident_too_long);
5093 Copy(s, d, t - s, char);
5104 if (PL_lex_state != LEX_NORMAL)
5105 PL_lex_state = LEX_INTERPENDMAYBE;
5108 if (*s == '$' && s[1] &&
5109 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5122 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5127 if (isSPACE(s[-1])) {
5130 if (ch != ' ' && ch != '\t') {
5136 if (isIDFIRST_lazy(d)) {
5140 while (e < send && isALNUM_lazy(e) || *e == ':') {
5142 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5145 Copy(s, d, e - s, char);
5150 while (isALNUM(*s) || *s == ':')
5154 while (s < send && (*s == ' ' || *s == '\t')) s++;
5155 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5156 dTHR; /* only for ckWARN */
5157 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5158 char *brack = *s == '[' ? "[...]" : "{...}";
5159 warner(WARN_AMBIGUOUS,
5160 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5161 funny, dest, brack, funny, dest, brack);
5163 PL_lex_fakebrack = PL_lex_brackets+1;
5165 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5171 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5172 PL_lex_state = LEX_INTERPEND;
5175 if (PL_lex_state == LEX_NORMAL) {
5176 dTHR; /* only for ckWARN */
5177 if (ckWARN(WARN_AMBIGUOUS) &&
5178 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5180 warner(WARN_AMBIGUOUS,
5181 "Ambiguous use of %c{%s} resolved to %c%s",
5182 funny, dest, funny, dest);
5187 s = bracket; /* let the parser handle it */
5191 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5192 PL_lex_state = LEX_INTERPEND;
5196 void pmflag(U16 *pmfl, int ch)
5201 *pmfl |= PMf_GLOBAL;
5203 *pmfl |= PMf_CONTINUE;
5207 *pmfl |= PMf_MULTILINE;
5209 *pmfl |= PMf_SINGLELINE;
5211 *pmfl |= PMf_EXTENDED;
5215 scan_pat(char *start, I32 type)
5220 s = scan_str(start);
5223 SvREFCNT_dec(PL_lex_stuff);
5224 PL_lex_stuff = Nullsv;
5225 croak("Search pattern not terminated");
5228 pm = (PMOP*)newPMOP(type, 0);
5229 if (PL_multi_open == '?')
5230 pm->op_pmflags |= PMf_ONCE;
5232 while (*s && strchr("iomsx", *s))
5233 pmflag(&pm->op_pmflags,*s++);
5236 while (*s && strchr("iogcmsx", *s))
5237 pmflag(&pm->op_pmflags,*s++);
5239 pm->op_pmpermflags = pm->op_pmflags;
5241 PL_lex_op = (OP*)pm;
5242 yylval.ival = OP_MATCH;
5247 scan_subst(char *start)
5254 yylval.ival = OP_NULL;
5256 s = scan_str(start);
5260 SvREFCNT_dec(PL_lex_stuff);
5261 PL_lex_stuff = Nullsv;
5262 croak("Substitution pattern not terminated");
5265 if (s[-1] == PL_multi_open)
5268 first_start = PL_multi_start;
5272 SvREFCNT_dec(PL_lex_stuff);
5273 PL_lex_stuff = Nullsv;
5275 SvREFCNT_dec(PL_lex_repl);
5276 PL_lex_repl = Nullsv;
5277 croak("Substitution replacement not terminated");
5279 PL_multi_start = first_start; /* so whole substitution is taken together */
5281 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5287 else if (strchr("iogcmsx", *s))
5288 pmflag(&pm->op_pmflags,*s++);
5295 pm->op_pmflags |= PMf_EVAL;
5296 repl = newSVpv("",0);
5298 sv_catpv(repl, es ? "eval " : "do ");
5299 sv_catpvn(repl, "{ ", 2);
5300 sv_catsv(repl, PL_lex_repl);
5301 sv_catpvn(repl, " };", 2);
5302 SvCOMPILED_on(repl);
5303 SvREFCNT_dec(PL_lex_repl);
5307 pm->op_pmpermflags = pm->op_pmflags;
5308 PL_lex_op = (OP*)pm;
5309 yylval.ival = OP_SUBST;
5314 scan_trans(char *start)
5325 yylval.ival = OP_NULL;
5327 s = scan_str(start);
5330 SvREFCNT_dec(PL_lex_stuff);
5331 PL_lex_stuff = Nullsv;
5332 croak("Transliteration pattern not terminated");
5334 if (s[-1] == PL_multi_open)
5340 SvREFCNT_dec(PL_lex_stuff);
5341 PL_lex_stuff = Nullsv;
5343 SvREFCNT_dec(PL_lex_repl);
5344 PL_lex_repl = Nullsv;
5345 croak("Transliteration replacement not terminated");
5349 o = newSVOP(OP_TRANS, 0, 0);
5350 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5353 New(803,tbl,256,short);
5354 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5358 complement = del = squash = 0;
5359 while (strchr("cdsCU", *s)) {
5361 complement = OPpTRANS_COMPLEMENT;
5363 del = OPpTRANS_DELETE;
5365 squash = OPpTRANS_SQUASH;
5370 utf8 &= ~OPpTRANS_FROM_UTF;
5372 utf8 |= OPpTRANS_FROM_UTF;
5376 utf8 &= ~OPpTRANS_TO_UTF;
5378 utf8 |= OPpTRANS_TO_UTF;
5381 croak("Too many /C and /U options");
5386 o->op_private = del|squash|complement|utf8;
5389 yylval.ival = OP_TRANS;
5394 scan_heredoc(register char *s)
5398 I32 op_type = OP_SCALAR;
5405 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5409 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5412 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5413 if (*peek && strchr("`'\"",*peek)) {
5416 s = delimcpy(d, e, s, PL_bufend, term, &len);
5426 if (!isALNUM_lazy(s))
5427 deprecate("bare << to mean <<\"\"");
5428 for (; isALNUM_lazy(s); s++) {
5433 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5434 croak("Delimiter for here document is too long");
5437 len = d - PL_tokenbuf;
5438 #ifndef PERL_STRICT_CR
5439 d = strchr(s, '\r');
5443 while (s < PL_bufend) {
5449 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5458 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5463 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5464 herewas = newSVpv(s,PL_bufend-s);
5466 s--, herewas = newSVpv(s,d-s);
5467 s += SvCUR(herewas);
5469 tmpstr = NEWSV(87,79);
5470 sv_upgrade(tmpstr, SVt_PVIV);
5475 else if (term == '`') {
5476 op_type = OP_BACKTICK;
5477 SvIVX(tmpstr) = '\\';
5481 PL_multi_start = PL_curcop->cop_line;
5482 PL_multi_open = PL_multi_close = '<';
5483 term = *PL_tokenbuf;
5486 while (s < PL_bufend &&
5487 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5489 PL_curcop->cop_line++;
5491 if (s >= PL_bufend) {
5492 PL_curcop->cop_line = PL_multi_start;
5493 missingterm(PL_tokenbuf);
5495 sv_setpvn(tmpstr,d+1,s-d);
5497 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5499 sv_catpvn(herewas,s,PL_bufend-s);
5500 sv_setsv(PL_linestr,herewas);
5501 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5502 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5505 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5506 while (s >= PL_bufend) { /* multiple line string? */
5508 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5509 PL_curcop->cop_line = PL_multi_start;
5510 missingterm(PL_tokenbuf);
5512 PL_curcop->cop_line++;
5513 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5514 #ifndef PERL_STRICT_CR
5515 if (PL_bufend - PL_linestart >= 2) {
5516 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5517 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5519 PL_bufend[-2] = '\n';
5521 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5523 else if (PL_bufend[-1] == '\r')
5524 PL_bufend[-1] = '\n';
5526 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5527 PL_bufend[-1] = '\n';
5529 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5530 SV *sv = NEWSV(88,0);
5532 sv_upgrade(sv, SVt_PVMG);
5533 sv_setsv(sv,PL_linestr);
5534 av_store(GvAV(PL_curcop->cop_filegv),
5535 (I32)PL_curcop->cop_line,sv);
5537 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5540 sv_catsv(PL_linestr,herewas);
5541 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5545 sv_catsv(tmpstr,PL_linestr);
5548 PL_multi_end = PL_curcop->cop_line;
5550 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5551 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5552 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5554 SvREFCNT_dec(herewas);
5555 PL_lex_stuff = tmpstr;
5556 yylval.ival = op_type;
5561 takes: current position in input buffer
5562 returns: new position in input buffer
5563 side-effects: yylval and lex_op are set.
5568 <FH> read from filehandle
5569 <pkg::FH> read from package qualified filehandle
5570 <pkg'FH> read from package qualified filehandle
5571 <$fh> read from filehandle in $fh
5577 scan_inputsymbol(char *start)
5579 register char *s = start; /* current position in buffer */
5584 d = PL_tokenbuf; /* start of temp holding space */
5585 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5586 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5588 /* die if we didn't have space for the contents of the <>,
5592 if (len >= sizeof PL_tokenbuf)
5593 croak("Excessively long <> operator");
5595 croak("Unterminated <> operator");
5600 Remember, only scalar variables are interpreted as filehandles by
5601 this code. Anything more complex (e.g., <$fh{$num}>) will be
5602 treated as a glob() call.
5603 This code makes use of the fact that except for the $ at the front,
5604 a scalar variable and a filehandle look the same.
5606 if (*d == '$' && d[1]) d++;
5608 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5609 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5612 /* If we've tried to read what we allow filehandles to look like, and
5613 there's still text left, then it must be a glob() and not a getline.
5614 Use scan_str to pull out the stuff between the <> and treat it
5615 as nothing more than a string.
5618 if (d - PL_tokenbuf != len) {
5619 yylval.ival = OP_GLOB;
5621 s = scan_str(start);
5623 croak("Glob not terminated");
5627 /* we're in a filehandle read situation */
5630 /* turn <> into <ARGV> */
5632 (void)strcpy(d,"ARGV");
5634 /* if <$fh>, create the ops to turn the variable into a
5640 /* try to find it in the pad for this block, otherwise find
5641 add symbol table ops
5643 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5644 OP *o = newOP(OP_PADSV, 0);
5646 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5649 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5650 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5651 newUNOP(OP_RV2GV, 0,
5652 newUNOP(OP_RV2SV, 0,
5653 newGVOP(OP_GV, 0, gv))));
5655 /* we created the ops in lex_op, so make yylval.ival a null op */
5656 yylval.ival = OP_NULL;
5659 /* If it's none of the above, it must be a literal filehandle
5660 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5662 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5663 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5664 yylval.ival = OP_NULL;
5673 takes: start position in buffer
5674 returns: position to continue reading from buffer
5675 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5676 updates the read buffer.
5678 This subroutine pulls a string out of the input. It is called for:
5679 q single quotes q(literal text)
5680 ' single quotes 'literal text'
5681 qq double quotes qq(interpolate $here please)
5682 " double quotes "interpolate $here please"
5683 qx backticks qx(/bin/ls -l)
5684 ` backticks `/bin/ls -l`
5685 qw quote words @EXPORT_OK = qw( func() $spam )
5686 m// regexp match m/this/
5687 s/// regexp substitute s/this/that/
5688 tr/// string transliterate tr/this/that/
5689 y/// string transliterate y/this/that/
5690 ($*@) sub prototypes sub foo ($)
5691 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5693 In most of these cases (all but <>, patterns and transliterate)
5694 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5695 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5696 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5699 It skips whitespace before the string starts, and treats the first
5700 character as the delimiter. If the delimiter is one of ([{< then
5701 the corresponding "close" character )]}> is used as the closing
5702 delimiter. It allows quoting of delimiters, and if the string has
5703 balanced delimiters ([{<>}]) it allows nesting.
5705 The lexer always reads these strings into lex_stuff, except in the
5706 case of the operators which take *two* arguments (s/// and tr///)
5707 when it checks to see if lex_stuff is full (presumably with the 1st
5708 arg to s or tr) and if so puts the string into lex_repl.
5713 scan_str(char *start)
5716 SV *sv; /* scalar value: string */
5717 char *tmps; /* temp string, used for delimiter matching */
5718 register char *s = start; /* current position in the buffer */
5719 register char term; /* terminating character */
5720 register char *to; /* current position in the sv's data */
5721 I32 brackets = 1; /* bracket nesting level */
5723 /* skip space before the delimiter */
5727 /* mark where we are, in case we need to report errors */
5730 /* after skipping whitespace, the next character is the terminator */
5732 /* mark where we are */
5733 PL_multi_start = PL_curcop->cop_line;
5734 PL_multi_open = term;
5736 /* find corresponding closing delimiter */
5737 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5739 PL_multi_close = term;
5741 /* create a new SV to hold the contents. 87 is leak category, I'm
5742 assuming. 79 is the SV's initial length. What a random number. */
5744 sv_upgrade(sv, SVt_PVIV);
5746 (void)SvPOK_only(sv); /* validate pointer */
5748 /* move past delimiter and try to read a complete string */
5751 /* extend sv if need be */
5752 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5753 /* set 'to' to the next character in the sv's string */
5754 to = SvPVX(sv)+SvCUR(sv);
5756 /* if open delimiter is the close delimiter read unbridle */
5757 if (PL_multi_open == PL_multi_close) {
5758 for (; s < PL_bufend; s++,to++) {
5759 /* embedded newlines increment the current line number */
5760 if (*s == '\n' && !PL_rsfp)
5761 PL_curcop->cop_line++;
5762 /* handle quoted delimiters */
5763 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5766 /* any other quotes are simply copied straight through */
5770 /* terminate when run out of buffer (the for() condition), or
5771 have found the terminator */
5772 else if (*s == term)
5778 /* if the terminator isn't the same as the start character (e.g.,
5779 matched brackets), we have to allow more in the quoting, and
5780 be prepared for nested brackets.
5783 /* read until we run out of string, or we find the terminator */
5784 for (; s < PL_bufend; s++,to++) {
5785 /* embedded newlines increment the line count */
5786 if (*s == '\n' && !PL_rsfp)
5787 PL_curcop->cop_line++;
5788 /* backslashes can escape the open or closing characters */
5789 if (*s == '\\' && s+1 < PL_bufend) {
5790 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5795 /* allow nested opens and closes */
5796 else if (*s == PL_multi_close && --brackets <= 0)
5798 else if (*s == PL_multi_open)
5803 /* terminate the copied string and update the sv's end-of-string */
5805 SvCUR_set(sv, to - SvPVX(sv));
5808 * this next chunk reads more into the buffer if we're not done yet
5811 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5813 #ifndef PERL_STRICT_CR
5814 if (to - SvPVX(sv) >= 2) {
5815 if ((to[-2] == '\r' && to[-1] == '\n') ||
5816 (to[-2] == '\n' && to[-1] == '\r'))
5820 SvCUR_set(sv, to - SvPVX(sv));
5822 else if (to[-1] == '\r')
5825 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5829 /* if we're out of file, or a read fails, bail and reset the current
5830 line marker so we can report where the unterminated string began
5833 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5835 PL_curcop->cop_line = PL_multi_start;
5838 /* we read a line, so increment our line counter */
5839 PL_curcop->cop_line++;
5841 /* update debugger info */
5842 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5843 SV *sv = NEWSV(88,0);
5845 sv_upgrade(sv, SVt_PVMG);
5846 sv_setsv(sv,PL_linestr);
5847 av_store(GvAV(PL_curcop->cop_filegv),
5848 (I32)PL_curcop->cop_line, sv);
5851 /* having changed the buffer, we must update PL_bufend */
5852 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5855 /* at this point, we have successfully read the delimited string */
5857 PL_multi_end = PL_curcop->cop_line;
5860 /* if we allocated too much space, give some back */
5861 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5862 SvLEN_set(sv, SvCUR(sv) + 1);
5863 Renew(SvPVX(sv), SvLEN(sv), char);
5866 /* decide whether this is the first or second quoted string we've read
5879 takes: pointer to position in buffer
5880 returns: pointer to new position in buffer
5881 side-effects: builds ops for the constant in yylval.op
5883 Read a number in any of the formats that Perl accepts:
5885 0(x[0-7A-F]+)|([0-7]+)
5886 [\d_]+(\.[\d_]*)?[Ee](\d+)
5888 Underbars (_) are allowed in decimal numbers. If -w is on,
5889 underbars before a decimal point must be at three digit intervals.
5891 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5894 If it reads a number without a decimal point or an exponent, it will
5895 try converting the number to an integer and see if it can do so
5896 without loss of precision.
5900 scan_num(char *start)
5902 register char *s = start; /* current position in buffer */
5903 register char *d; /* destination in temp buffer */
5904 register char *e; /* end of temp buffer */
5905 I32 tryiv; /* used to see if it can be an int */
5906 double value; /* number read, as a double */
5907 SV *sv; /* place to put the converted number */
5908 I32 floatit; /* boolean: int or float? */
5909 char *lastub = 0; /* position of last underbar */
5910 static char number_too_long[] = "Number too long";
5912 /* We use the first character to decide what type of number this is */
5916 croak("panic: scan_num");
5918 /* if it starts with a 0, it could be an octal number, a decimal in
5919 0.13 disguise, or a hexadecimal number.
5924 u holds the "number so far"
5925 shift the power of 2 of the base (hex == 4, octal == 3)
5926 overflowed was the number more than we can hold?
5928 Shift is used when we add a digit. It also serves as an "are
5929 we in octal or hex?" indicator to disallow hex characters when
5934 bool overflowed = FALSE;
5941 /* check for a decimal in disguise */
5942 else if (s[1] == '.')
5944 /* so it must be octal */
5949 /* read the rest of the octal number */
5951 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5955 /* if we don't mention it, we're done */
5964 /* 8 and 9 are not octal */
5967 yyerror("Illegal octal digit");
5971 case '0': case '1': case '2': case '3': case '4':
5972 case '5': case '6': case '7':
5973 b = *s++ & 15; /* ASCII digit -> value of digit */
5977 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5978 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5979 /* make sure they said 0x */
5984 /* Prepare to put the digit we have onto the end
5985 of the number so far. We check for overflows.
5989 n = u << shift; /* make room for the digit */
5990 if (!overflowed && (n >> shift) != u
5991 && !(PL_hints & HINT_NEW_BINARY)) {
5992 warn("Integer overflow in %s number",
5993 (shift == 4) ? "hex" : "octal");
5996 u = n | b; /* add the digit to the end */
6001 /* if we get here, we had success: make a scalar value from
6007 if ( PL_hints & HINT_NEW_BINARY)
6008 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6013 handle decimal numbers.
6014 we're also sent here when we read a 0 as the first digit
6016 case '1': case '2': case '3': case '4': case '5':
6017 case '6': case '7': case '8': case '9': case '.':
6020 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6023 /* read next group of digits and _ and copy into d */
6024 while (isDIGIT(*s) || *s == '_') {
6025 /* skip underscores, checking for misplaced ones
6029 dTHR; /* only for ckWARN */
6030 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6031 warner(WARN_SYNTAX, "Misplaced _ in number");
6035 /* check for end of fixed-length buffer */
6037 croak(number_too_long);
6038 /* if we're ok, copy the character */
6043 /* final misplaced underbar check */
6044 if (lastub && s - lastub != 3) {
6046 if (ckWARN(WARN_SYNTAX))
6047 warner(WARN_SYNTAX, "Misplaced _ in number");
6050 /* read a decimal portion if there is one. avoid
6051 3..5 being interpreted as the number 3. followed
6054 if (*s == '.' && s[1] != '.') {
6058 /* copy, ignoring underbars, until we run out of
6059 digits. Note: no misplaced underbar checks!
6061 for (; isDIGIT(*s) || *s == '_'; s++) {
6062 /* fixed length buffer check */
6064 croak(number_too_long);
6070 /* read exponent part, if present */
6071 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6075 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6076 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6078 /* allow positive or negative exponent */
6079 if (*s == '+' || *s == '-')
6082 /* read digits of exponent (no underbars :-) */
6083 while (isDIGIT(*s)) {
6085 croak(number_too_long);
6090 /* terminate the string */
6093 /* make an sv from the string */
6095 /* reset numeric locale in case we were earlier left in Swaziland */
6096 SET_NUMERIC_STANDARD();
6097 value = atof(PL_tokenbuf);
6100 See if we can make do with an integer value without loss of
6101 precision. We use I_V to cast to an int, because some
6102 compilers have issues. Then we try casting it back and see
6103 if it was the same. We only do this if we know we
6104 specifically read an integer.
6106 Note: if floatit is true, then we don't need to do the
6110 if (!floatit && (double)tryiv == value)
6111 sv_setiv(sv, tryiv);
6113 sv_setnv(sv, value);
6114 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6115 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6116 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6120 /* make the op for the constant and return */
6122 yylval.opval = newSVOP(OP_CONST, 0, sv);
6128 scan_formline(register char *s)
6133 SV *stuff = newSVpv("",0);
6134 bool needargs = FALSE;
6137 if (*s == '.' || *s == '}') {
6139 #ifdef PERL_STRICT_CR
6140 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6142 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6147 if (PL_in_eval && !PL_rsfp) {
6148 eol = strchr(s,'\n');
6153 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6155 for (t = s; t < eol; t++) {
6156 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6158 goto enough; /* ~~ must be first line in formline */
6160 if (*t == '@' || *t == '^')
6163 sv_catpvn(stuff, s, eol-s);
6167 s = filter_gets(PL_linestr, PL_rsfp, 0);
6168 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6169 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6172 yyerror("Format not terminated");
6182 PL_lex_state = LEX_NORMAL;
6183 PL_nextval[PL_nexttoke].ival = 0;
6187 PL_lex_state = LEX_FORMLINE;
6188 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6190 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6194 SvREFCNT_dec(stuff);
6195 PL_lex_formbrack = 0;
6206 PL_cshlen = strlen(PL_cshname);
6211 start_subparse(I32 is_format, U32 flags)
6214 I32 oldsavestack_ix = PL_savestack_ix;
6215 CV* outsidecv = PL_compcv;
6219 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6221 save_I32(&PL_subline);
6222 save_item(PL_subname);
6224 SAVESPTR(PL_curpad);
6225 SAVESPTR(PL_comppad);
6226 SAVESPTR(PL_comppad_name);
6227 SAVESPTR(PL_compcv);
6228 SAVEI32(PL_comppad_name_fill);
6229 SAVEI32(PL_min_intro_pending);
6230 SAVEI32(PL_max_intro_pending);
6231 SAVEI32(PL_pad_reset_pending);
6233 PL_compcv = (CV*)NEWSV(1104,0);
6234 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6235 CvFLAGS(PL_compcv) |= flags;
6237 PL_comppad = newAV();
6238 av_push(PL_comppad, Nullsv);
6239 PL_curpad = AvARRAY(PL_comppad);
6240 PL_comppad_name = newAV();
6241 PL_comppad_name_fill = 0;
6242 PL_min_intro_pending = 0;
6244 PL_subline = PL_curcop->cop_line;
6246 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6247 PL_curpad[0] = (SV*)newAV();
6248 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6249 #endif /* USE_THREADS */
6251 comppadlist = newAV();
6252 AvREAL_off(comppadlist);
6253 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6254 av_store(comppadlist, 1, (SV*)PL_comppad);
6256 CvPADLIST(PL_compcv) = comppadlist;
6257 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6259 CvOWNER(PL_compcv) = 0;
6260 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6261 MUTEX_INIT(CvMUTEXP(PL_compcv));
6262 #endif /* USE_THREADS */
6264 return oldsavestack_ix;
6283 char *context = NULL;
6287 if (!yychar || (yychar == ';' && !PL_rsfp))
6289 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6290 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6291 while (isSPACE(*PL_oldoldbufptr))
6293 context = PL_oldoldbufptr;
6294 contlen = PL_bufptr - PL_oldoldbufptr;
6296 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6297 PL_oldbufptr != PL_bufptr) {
6298 while (isSPACE(*PL_oldbufptr))
6300 context = PL_oldbufptr;
6301 contlen = PL_bufptr - PL_oldbufptr;
6303 else if (yychar > 255)
6304 where = "next token ???";
6305 else if ((yychar & 127) == 127) {
6306 if (PL_lex_state == LEX_NORMAL ||
6307 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6308 where = "at end of line";
6309 else if (PL_lex_inpat)
6310 where = "within pattern";
6312 where = "within string";
6315 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6317 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6318 else if (isPRINT_LC(yychar))
6319 sv_catpvf(where_sv, "%c", yychar);
6321 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6322 where = SvPVX(where_sv);
6324 msg = sv_2mortal(newSVpv(s, 0));
6325 sv_catpvf(msg, " at %_ line %ld, ",
6326 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6328 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6330 sv_catpvf(msg, "%s\n", where);
6331 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6333 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6334 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6339 else if (PL_in_eval)
6340 sv_catsv(ERRSV, msg);
6342 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6343 if (++PL_error_count >= 10)
6344 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6346 PL_in_my_stash = Nullhv;