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 end of line?)\n");
205 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
215 char *nl = strrchr(s,'\n');
221 iscntrl(PL_multi_close)
223 PL_multi_close < 32 || PL_multi_close == 127
227 tmpbuf[1] = toCTRL(PL_multi_close);
233 *tmpbuf = PL_multi_close;
237 q = strchr(s,'"') ? '\'' : '"';
238 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
245 if (ckWARN(WARN_DEPRECATED))
246 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
252 deprecate("comma-less variable list");
258 win32_textfilter(int idx, SV *sv, int maxlen)
260 I32 count = FILTER_READ(idx+1, sv, maxlen);
261 if (count > 0 && !maxlen)
262 win32_strip_return(sv);
270 utf16_textfilter(int idx, SV *sv, int maxlen)
272 I32 count = FILTER_READ(idx+1, sv, maxlen);
276 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
277 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
278 sv_usepvn(sv, (char*)tmps, tend - tmps);
285 utf16rev_textfilter(int idx, SV *sv, int maxlen)
287 I32 count = FILTER_READ(idx+1, sv, maxlen);
291 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
292 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
293 sv_usepvn(sv, (char*)tmps, tend - tmps);
308 SAVEI32(PL_lex_dojoin);
309 SAVEI32(PL_lex_brackets);
310 SAVEI32(PL_lex_fakebrack);
311 SAVEI32(PL_lex_casemods);
312 SAVEI32(PL_lex_starts);
313 SAVEI32(PL_lex_state);
314 SAVESPTR(PL_lex_inpat);
315 SAVEI32(PL_lex_inwhat);
316 SAVEI16(PL_curcop->cop_line);
319 SAVEPPTR(PL_oldbufptr);
320 SAVEPPTR(PL_oldoldbufptr);
321 SAVEPPTR(PL_linestart);
322 SAVESPTR(PL_linestr);
323 SAVEPPTR(PL_lex_brackstack);
324 SAVEPPTR(PL_lex_casestack);
325 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
326 SAVESPTR(PL_lex_stuff);
327 SAVEI32(PL_lex_defer);
328 SAVESPTR(PL_lex_repl);
329 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
330 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
332 PL_lex_state = LEX_NORMAL;
336 PL_lex_fakebrack = 0;
337 New(899, PL_lex_brackstack, 120, char);
338 New(899, PL_lex_casestack, 12, char);
339 SAVEFREEPV(PL_lex_brackstack);
340 SAVEFREEPV(PL_lex_casestack);
342 *PL_lex_casestack = '\0';
345 PL_lex_stuff = Nullsv;
346 PL_lex_repl = Nullsv;
350 if (SvREADONLY(PL_linestr))
351 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
352 s = SvPV(PL_linestr, len);
353 if (len && s[len-1] != ';') {
354 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
355 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
356 sv_catpvn(PL_linestr, "\n;", 2);
358 SvTEMP_off(PL_linestr);
359 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
360 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
362 PL_rs = newSVpv("\n", 1);
369 PL_doextract = FALSE;
373 restore_rsfp(void *f)
375 PerlIO *fp = (PerlIO*)f;
377 if (PL_rsfp == PerlIO_stdin())
378 PerlIO_clearerr(PL_rsfp);
379 else if (PL_rsfp && (PL_rsfp != fp))
380 PerlIO_close(PL_rsfp);
385 restore_expect(void *e)
387 /* a safe way to store a small integer in a pointer */
388 PL_expect = (expectation)((char *)e - PL_tokenbuf);
392 restore_lex_expect(void *e)
394 /* a safe way to store a small integer in a pointer */
395 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
407 PL_curcop->cop_line++;
410 while (*s == ' ' || *s == '\t') s++;
411 if (strnEQ(s, "line ", 5)) {
420 while (*s == ' ' || *s == '\t')
422 if (*s == '"' && (t = strchr(s+1, '"')))
426 return; /* false alarm */
427 for (t = s; !isSPACE(*t); t++) ;
432 PL_curcop->cop_filegv = gv_fetchfile(s);
434 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
436 PL_curcop->cop_line = atoi(n)-1;
440 skipspace(register char *s)
443 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
444 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
450 while (s < PL_bufend && isSPACE(*s)) {
451 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
454 if (s < PL_bufend && *s == '#') {
455 while (s < PL_bufend && *s != '\n')
459 if (PL_in_eval && !PL_rsfp) {
465 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
467 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
468 if (PL_minus_n || PL_minus_p) {
469 sv_setpv(PL_linestr,PL_minus_p ?
470 ";}continue{print or die qq(-p destination: $!\\n)" :
472 sv_catpv(PL_linestr,";}");
473 PL_minus_n = PL_minus_p = 0;
476 sv_setpv(PL_linestr,";");
477 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
478 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
479 if (PL_preprocess && !PL_in_eval)
480 (void)PerlProc_pclose(PL_rsfp);
481 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
482 PerlIO_clearerr(PL_rsfp);
484 (void)PerlIO_close(PL_rsfp);
488 PL_linestart = PL_bufptr = s + prevlen;
489 PL_bufend = s + SvCUR(PL_linestr);
492 if (PERLDB_LINE && PL_curstash != PL_debstash) {
493 SV *sv = NEWSV(85,0);
495 sv_upgrade(sv, SVt_PVMG);
496 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
497 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
508 if (PL_oldoldbufptr != PL_last_uni)
510 while (isSPACE(*PL_last_uni))
512 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
513 if ((t = strchr(s, '(')) && t < PL_bufptr)
517 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
524 #define UNI(f) return uni(f,s)
532 PL_last_uni = PL_oldbufptr;
543 #endif /* CRIPPLED_CC */
545 #define LOP(f,x) return lop(f,x,s)
548 lop(I32 f, expectation x, char *s)
555 PL_last_lop = PL_oldbufptr;
571 PL_nexttype[PL_nexttoke] = type;
573 if (PL_lex_state != LEX_KNOWNEXT) {
574 PL_lex_defer = PL_lex_state;
575 PL_lex_expect = PL_expect;
576 PL_lex_state = LEX_KNOWNEXT;
581 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
586 start = skipspace(start);
588 if (isIDFIRST_lazy(s) ||
589 (allow_pack && *s == ':') ||
590 (allow_initial_tick && *s == '\'') )
592 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
593 if (check_keyword && keyword(PL_tokenbuf, len))
595 if (token == METHOD) {
600 PL_expect = XOPERATOR;
603 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
604 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
611 force_ident(register char *s, int kind)
614 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
615 PL_nextval[PL_nexttoke].opval = o;
618 dTHR; /* just for in_eval */
619 o->op_private = OPpCONST_ENTERED;
620 /* XXX see note in pp_entereval() for why we forgo typo
621 warnings if the symbol must be introduced in an eval.
623 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
624 kind == '$' ? SVt_PV :
625 kind == '@' ? SVt_PVAV :
626 kind == '%' ? SVt_PVHV :
634 force_version(char *s)
636 OP *version = Nullop;
640 /* default VERSION number -- GBARR */
645 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
646 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
648 /* real VERSION number -- GBARR */
649 version = yylval.opval;
653 /* NOTE: The parser sees the package name and the VERSION swapped */
654 PL_nextval[PL_nexttoke].opval = version;
672 s = SvPV_force(sv, len);
676 while (s < send && *s != '\\')
681 if ( PL_hints & HINT_NEW_STRING )
682 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
685 if (s + 1 < send && (s[1] == '\\'))
686 s++; /* all that, just for this */
691 SvCUR_set(sv, d - SvPVX(sv));
693 if ( PL_hints & HINT_NEW_STRING )
694 return new_constant(NULL, 0, "q", sv, pv, "q");
701 register I32 op_type = yylval.ival;
703 if (op_type == OP_NULL) {
704 yylval.opval = PL_lex_op;
708 if (op_type == OP_CONST || op_type == OP_READLINE) {
709 SV *sv = tokeq(PL_lex_stuff);
711 if (SvTYPE(sv) == SVt_PVIV) {
712 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
718 nsv = newSVpv(p, len);
722 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
723 PL_lex_stuff = Nullsv;
727 PL_sublex_info.super_state = PL_lex_state;
728 PL_sublex_info.sub_inwhat = op_type;
729 PL_sublex_info.sub_op = PL_lex_op;
730 PL_lex_state = LEX_INTERPPUSH;
734 yylval.opval = PL_lex_op;
748 PL_lex_state = PL_sublex_info.super_state;
749 SAVEI32(PL_lex_dojoin);
750 SAVEI32(PL_lex_brackets);
751 SAVEI32(PL_lex_fakebrack);
752 SAVEI32(PL_lex_casemods);
753 SAVEI32(PL_lex_starts);
754 SAVEI32(PL_lex_state);
755 SAVESPTR(PL_lex_inpat);
756 SAVEI32(PL_lex_inwhat);
757 SAVEI16(PL_curcop->cop_line);
759 SAVEPPTR(PL_oldbufptr);
760 SAVEPPTR(PL_oldoldbufptr);
761 SAVEPPTR(PL_linestart);
762 SAVESPTR(PL_linestr);
763 SAVEPPTR(PL_lex_brackstack);
764 SAVEPPTR(PL_lex_casestack);
766 PL_linestr = PL_lex_stuff;
767 PL_lex_stuff = Nullsv;
769 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
770 PL_bufend += SvCUR(PL_linestr);
771 SAVEFREESV(PL_linestr);
773 PL_lex_dojoin = FALSE;
775 PL_lex_fakebrack = 0;
776 New(899, PL_lex_brackstack, 120, char);
777 New(899, PL_lex_casestack, 12, char);
778 SAVEFREEPV(PL_lex_brackstack);
779 SAVEFREEPV(PL_lex_casestack);
781 *PL_lex_casestack = '\0';
783 PL_lex_state = LEX_INTERPCONCAT;
784 PL_curcop->cop_line = PL_multi_start;
786 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
787 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
788 PL_lex_inpat = PL_sublex_info.sub_op;
790 PL_lex_inpat = Nullop;
798 if (!PL_lex_starts++) {
799 PL_expect = XOPERATOR;
800 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
804 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
805 PL_lex_state = LEX_INTERPCASEMOD;
806 return yylex(PERL_YYLEX_PARAM);
809 /* Is there a right-hand side to take care of? */
810 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
811 PL_linestr = PL_lex_repl;
813 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
814 PL_bufend += SvCUR(PL_linestr);
815 SAVEFREESV(PL_linestr);
816 PL_lex_dojoin = FALSE;
818 PL_lex_fakebrack = 0;
820 *PL_lex_casestack = '\0';
822 if (SvCOMPILED(PL_lex_repl)) {
823 PL_lex_state = LEX_INTERPNORMAL;
825 /* we don't clear PL_lex_repl here, so that we can check later
826 whether this is an evalled subst; that means we rely on the
827 logic to ensure sublex_done() is called again only via the
828 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
831 PL_lex_state = LEX_INTERPCONCAT;
832 PL_lex_repl = Nullsv;
838 PL_bufend = SvPVX(PL_linestr);
839 PL_bufend += SvCUR(PL_linestr);
840 PL_expect = XOPERATOR;
848 Extracts a pattern, double-quoted string, or transliteration. This
851 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
852 processing a pattern (PL_lex_inpat is true), a transliteration
853 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
855 Returns a pointer to the character scanned up to. Iff this is
856 advanced from the start pointer supplied (ie if anything was
857 successfully parsed), will leave an OP for the substring scanned
858 in yylval. Caller must intuit reason for not parsing further
859 by looking at the next characters herself.
863 double-quoted style: \r and \n
864 regexp special ones: \D \s
866 backrefs: \1 (deprecated in substitution replacements)
867 case and quoting: \U \Q \E
868 stops on @ and $, but not for $ as tail anchor
871 characters are VERY literal, except for - not at the start or end
872 of the string, which indicates a range. scan_const expands the
873 range to the full set of intermediate characters.
875 In double-quoted strings:
877 double-quoted style: \r and \n
879 backrefs: \1 (deprecated)
880 case and quoting: \U \Q \E
883 scan_const does *not* construct ops to handle interpolated strings.
884 It stops processing as soon as it finds an embedded $ or @ variable
885 and leaves it to the caller to work out what's going on.
887 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
889 $ in pattern could be $foo or could be tail anchor. Assumption:
890 it's a tail anchor if $ is the last thing in the string, or if it's
891 followed by one of ")| \n\t"
893 \1 (backreferences) are turned into $1
895 The structure of the code is
896 while (there's a character to process) {
897 handle transliteration ranges
899 skip # initiated comments in //x patterns
900 check for embedded @foo
901 check for embedded scalars
903 leave intact backslashes from leave (below)
904 deprecate \1 in strings and sub replacements
905 handle string-changing backslashes \l \U \Q \E, etc.
906 switch (what was escaped) {
907 handle - in a transliteration (becomes a literal -)
908 handle \132 octal characters
909 handle 0x15 hex characters
910 handle \cV (control V)
911 handle printf backslashes (\f, \r, \n, etc)
914 } (end while character to read)
919 scan_const(char *start)
921 register char *send = PL_bufend; /* end of the constant */
922 SV *sv = NEWSV(93, send - start); /* sv for the constant */
923 register char *s = start; /* start of the constant */
924 register char *d = SvPVX(sv); /* destination for copies */
925 bool dorange = FALSE; /* are we in a translit range? */
927 I32 utf = PL_lex_inwhat == OP_TRANS
928 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
930 I32 thisutf = PL_lex_inwhat == OP_TRANS
931 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
934 /* leaveit is the set of acceptably-backslashed characters */
937 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
940 while (s < send || dorange) {
941 /* get transliterations out of the way (they're most literal) */
942 if (PL_lex_inwhat == OP_TRANS) {
943 /* expand a range A-Z to the full set of characters. AIE! */
945 I32 i; /* current expanded character */
946 I32 min; /* first character in range */
947 I32 max; /* last character in range */
949 i = d - SvPVX(sv); /* remember current offset */
950 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
951 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
952 d -= 2; /* eat the first char and the - */
954 min = (U8)*d; /* first char in range */
955 max = (U8)d[1]; /* last char in range */
958 if ((isLOWER(min) && isLOWER(max)) ||
959 (isUPPER(min) && isUPPER(max))) {
961 for (i = min; i <= max; i++)
965 for (i = min; i <= max; i++)
972 for (i = min; i <= max; i++)
975 /* mark the range as done, and continue */
980 /* range begins (ignore - as first or last char) */
981 else if (*s == '-' && s+1 < send && s != start) {
983 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
992 /* if we get here, we're not doing a transliteration */
994 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
995 except for the last char, which will be done separately. */
996 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
998 while (s < send && *s != ')')
1000 } else if (s[2] == '{'
1001 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1003 char *regparse = s + (s[2] == '{' ? 3 : 4);
1006 while (count && (c = *regparse)) {
1007 if (c == '\\' && regparse[1])
1015 if (*regparse != ')') {
1016 regparse--; /* Leave one char for continuation. */
1017 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1019 while (s < regparse)
1024 /* likewise skip #-initiated comments in //x patterns */
1025 else if (*s == '#' && PL_lex_inpat &&
1026 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1027 while (s+1 < send && *s != '\n')
1031 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1032 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1035 /* check for embedded scalars. only stop if we're sure it's a
1038 else if (*s == '$') {
1039 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1041 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1042 break; /* in regexp, $ might be tail anchor */
1045 /* (now in tr/// code again) */
1047 if (*s & 0x80 && thisutf) {
1048 dTHR; /* only for ckWARN */
1049 if (ckWARN(WARN_UTF8)) {
1050 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1060 if (*s == '\\' && s+1 < send) {
1063 /* some backslashes we leave behind */
1064 if (*leaveit && *s && strchr(leaveit, *s)) {
1070 /* deprecate \1 in strings and substitution replacements */
1071 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1072 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1074 dTHR; /* only for ckWARN */
1075 if (ckWARN(WARN_SYNTAX))
1076 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1081 /* string-change backslash escapes */
1082 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1087 /* if we get here, it's either a quoted -, or a digit */
1090 /* quoted - in transliterations */
1092 if (PL_lex_inwhat == OP_TRANS) {
1100 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1102 "Unrecognized escape \\%c passed through",
1104 /* default action is to copy the quoted character */
1109 /* \132 indicates an octal constant */
1110 case '0': case '1': case '2': case '3':
1111 case '4': case '5': case '6': case '7':
1112 *d++ = scan_oct(s, 3, &len);
1116 /* \x24 indicates a hex constant */
1120 char* e = strchr(s, '}');
1123 yyerror("Missing right brace on \\x{}");
1128 if (ckWARN(WARN_UTF8))
1130 "Use of \\x{} without utf8 declaration");
1132 /* note: utf always shorter than hex */
1133 d = (char*)uv_to_utf8((U8*)d,
1134 scan_hex(s + 1, e - s - 1, &len));
1139 UV uv = (UV)scan_hex(s, 2, &len);
1140 if (utf && PL_lex_inwhat == OP_TRANS &&
1141 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1143 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1146 if (uv >= 127 && UTF) {
1148 if (ckWARN(WARN_UTF8))
1150 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1159 /* \c is a control character */
1173 /* printf-style backslashes, formfeeds, newlines, etc */
1199 } /* end if (backslash) */
1202 } /* while loop to process each character */
1204 /* terminate the string and set up the sv */
1206 SvCUR_set(sv, d - SvPVX(sv));
1209 /* shrink the sv if we allocated more than we used */
1210 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1211 SvLEN_set(sv, SvCUR(sv) + 1);
1212 Renew(SvPVX(sv), SvLEN(sv), char);
1215 /* return the substring (via yylval) only if we parsed anything */
1216 if (s > PL_bufptr) {
1217 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1218 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1220 ( PL_lex_inwhat == OP_TRANS
1222 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1225 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1231 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1233 intuit_more(register char *s)
1235 if (PL_lex_brackets)
1237 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1239 if (*s != '{' && *s != '[')
1244 /* In a pattern, so maybe we have {n,m}. */
1261 /* On the other hand, maybe we have a character class */
1264 if (*s == ']' || *s == '^')
1267 int weight = 2; /* let's weigh the evidence */
1269 unsigned char un_char = 255, last_un_char;
1270 char *send = strchr(s,']');
1271 char tmpbuf[sizeof PL_tokenbuf * 4];
1273 if (!send) /* has to be an expression */
1276 Zero(seen,256,char);
1279 else if (isDIGIT(*s)) {
1281 if (isDIGIT(s[1]) && s[2] == ']')
1287 for (; s < send; s++) {
1288 last_un_char = un_char;
1289 un_char = (unsigned char)*s;
1294 weight -= seen[un_char] * 10;
1295 if (isALNUM_lazy(s+1)) {
1296 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1297 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1302 else if (*s == '$' && s[1] &&
1303 strchr("[#!%*<>()-=",s[1])) {
1304 if (/*{*/ strchr("])} =",s[2]))
1313 if (strchr("wds]",s[1]))
1315 else if (seen['\''] || seen['"'])
1317 else if (strchr("rnftbxcav",s[1]))
1319 else if (isDIGIT(s[1])) {
1321 while (s[1] && isDIGIT(s[1]))
1331 if (strchr("aA01! ",last_un_char))
1333 if (strchr("zZ79~",s[1]))
1335 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1336 weight -= 5; /* cope with negative subscript */
1339 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1340 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1345 if (keyword(tmpbuf, d - tmpbuf))
1348 if (un_char == last_un_char + 1)
1350 weight -= seen[un_char];
1355 if (weight >= 0) /* probably a character class */
1363 intuit_method(char *start, GV *gv)
1365 char *s = start + (*start == '$');
1366 char tmpbuf[sizeof PL_tokenbuf];
1374 if ((cv = GvCVu(gv))) {
1375 char *proto = SvPVX(cv);
1385 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1386 if (*start == '$') {
1387 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1392 return *s == '(' ? FUNCMETH : METHOD;
1394 if (!keyword(tmpbuf, len)) {
1395 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1400 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1401 if (indirgv && GvCVu(indirgv))
1403 /* filehandle or package name makes it a method */
1404 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1406 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1407 return 0; /* no assumptions -- "=>" quotes bearword */
1409 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1411 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1415 return *s == '(' ? FUNCMETH : METHOD;
1425 char *pdb = PerlEnv_getenv("PERL5DB");
1429 SETERRNO(0,SS$_NORMAL);
1430 return "BEGIN { require 'perl5db.pl' }";
1436 /* Encoded script support. filter_add() effectively inserts a
1437 * 'pre-processing' function into the current source input stream.
1438 * Note that the filter function only applies to the current source file
1439 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1441 * The datasv parameter (which may be NULL) can be used to pass
1442 * private data to this instance of the filter. The filter function
1443 * can recover the SV using the FILTER_DATA macro and use it to
1444 * store private buffers and state information.
1446 * The supplied datasv parameter is upgraded to a PVIO type
1447 * and the IoDIRP field is used to store the function pointer.
1448 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1449 * private use must be set using malloc'd pointers.
1453 filter_add(filter_t funcp, SV *datasv)
1455 if (!funcp){ /* temporary handy debugging hack to be deleted */
1456 PL_filter_debug = atoi((char*)datasv);
1459 if (!PL_rsfp_filters)
1460 PL_rsfp_filters = newAV();
1462 datasv = NEWSV(255,0);
1463 if (!SvUPGRADE(datasv, SVt_PVIO))
1464 die("Can't upgrade filter_add data to SVt_PVIO");
1465 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1466 if (PL_filter_debug) {
1468 warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1470 av_unshift(PL_rsfp_filters, 1);
1471 av_store(PL_rsfp_filters, 0, datasv) ;
1476 /* Delete most recently added instance of this filter function. */
1478 filter_del(filter_t funcp)
1480 if (PL_filter_debug)
1481 warn("filter_del func %p", funcp);
1482 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1484 /* if filter is on top of stack (usual case) just pop it off */
1485 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1486 sv_free(av_pop(PL_rsfp_filters));
1490 /* we need to search for the correct entry and clear it */
1491 die("filter_del can only delete in reverse order (currently)");
1495 /* Invoke the n'th filter function for the current rsfp. */
1497 filter_read(int idx, SV *buf_sv, int maxlen)
1500 /* 0 = read one text line */
1505 if (!PL_rsfp_filters)
1507 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1508 /* Provide a default input filter to make life easy. */
1509 /* Note that we append to the line. This is handy. */
1510 if (PL_filter_debug)
1511 warn("filter_read %d: from rsfp\n", idx);
1515 int old_len = SvCUR(buf_sv) ;
1517 /* ensure buf_sv is large enough */
1518 SvGROW(buf_sv, old_len + maxlen) ;
1519 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1520 if (PerlIO_error(PL_rsfp))
1521 return -1; /* error */
1523 return 0 ; /* end of file */
1525 SvCUR_set(buf_sv, old_len + len) ;
1528 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1529 if (PerlIO_error(PL_rsfp))
1530 return -1; /* error */
1532 return 0 ; /* end of file */
1535 return SvCUR(buf_sv);
1537 /* Skip this filter slot if filter has been deleted */
1538 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1539 if (PL_filter_debug)
1540 warn("filter_read %d: skipped (filter deleted)\n", idx);
1541 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1543 /* Get function pointer hidden within datasv */
1544 funcp = (filter_t)IoDIRP(datasv);
1545 if (PL_filter_debug) {
1547 warn("filter_read %d: via function %p (%s)\n",
1548 idx, funcp, SvPV(datasv,n_a));
1550 /* Call function. The function is expected to */
1551 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1552 /* Return: <0:error, =0:eof, >0:not eof */
1553 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1557 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1560 if (!PL_rsfp_filters) {
1561 filter_add(win32_textfilter,NULL);
1564 if (PL_rsfp_filters) {
1567 SvCUR_set(sv, 0); /* start with empty line */
1568 if (FILTER_READ(0, sv, 0) > 0)
1569 return ( SvPVX(sv) ) ;
1574 return (sv_gets(sv, fp, append));
1579 static char* exp_name[] =
1580 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1586 Works out what to call the token just pulled out of the input
1587 stream. The yacc parser takes care of taking the ops we return and
1588 stitching them into a tree.
1594 if read an identifier
1595 if we're in a my declaration
1596 croak if they tried to say my($foo::bar)
1597 build the ops for a my() declaration
1598 if it's an access to a my() variable
1599 are we in a sort block?
1600 croak if my($a); $a <=> $b
1601 build ops for access to a my() variable
1602 if in a dq string, and they've said @foo and we can't find @foo
1604 build ops for a bareword
1605 if we already built the token before, use it.
1608 int yylex(PERL_YYLEX_PARAM_DECL)
1618 #ifdef USE_PURE_BISON
1619 yylval_pointer = lvalp;
1620 yychar_pointer = lcharp;
1623 /* check if there's an identifier for us to look at */
1624 if (PL_pending_ident) {
1625 /* pit holds the identifier we read and pending_ident is reset */
1626 char pit = PL_pending_ident;
1627 PL_pending_ident = 0;
1629 /* if we're in a my(), we can't allow dynamics here.
1630 $foo'bar has already been turned into $foo::bar, so
1631 just check for colons.
1633 if it's a legal name, the OP is a PADANY.
1636 if (strchr(PL_tokenbuf,':'))
1637 croak(PL_no_myglob,PL_tokenbuf);
1639 yylval.opval = newOP(OP_PADANY, 0);
1640 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1645 build the ops for accesses to a my() variable.
1647 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1648 then used in a comparison. This catches most, but not
1649 all cases. For instance, it catches
1650 sort { my($a); $a <=> $b }
1652 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1653 (although why you'd do that is anyone's guess).
1656 if (!strchr(PL_tokenbuf,':')) {
1658 /* Check for single character per-thread SVs */
1659 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1660 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1661 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1663 yylval.opval = newOP(OP_THREADSV, 0);
1664 yylval.opval->op_targ = tmp;
1667 #endif /* USE_THREADS */
1668 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1669 /* if it's a sort block and they're naming $a or $b */
1670 if (PL_last_lop_op == OP_SORT &&
1671 PL_tokenbuf[0] == '$' &&
1672 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1675 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1676 d < PL_bufend && *d != '\n';
1679 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1680 croak("Can't use \"my %s\" in sort comparison",
1686 yylval.opval = newOP(OP_PADANY, 0);
1687 yylval.opval->op_targ = tmp;
1693 Whine if they've said @foo in a doublequoted string,
1694 and @foo isn't a variable we can find in the symbol
1697 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1698 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1699 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1700 yyerror(form("In string, %s now must be written as \\%s",
1701 PL_tokenbuf, PL_tokenbuf));
1704 /* build ops for a bareword */
1705 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1706 yylval.opval->op_private = OPpCONST_ENTERED;
1707 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1708 ((PL_tokenbuf[0] == '$') ? SVt_PV
1709 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1714 /* no identifier pending identification */
1716 switch (PL_lex_state) {
1718 case LEX_NORMAL: /* Some compilers will produce faster */
1719 case LEX_INTERPNORMAL: /* code if we comment these out. */
1723 /* when we're already built the next token, just pull it out the queue */
1726 yylval = PL_nextval[PL_nexttoke];
1728 PL_lex_state = PL_lex_defer;
1729 PL_expect = PL_lex_expect;
1730 PL_lex_defer = LEX_NORMAL;
1732 return(PL_nexttype[PL_nexttoke]);
1734 /* interpolated case modifiers like \L \U, including \Q and \E.
1735 when we get here, PL_bufptr is at the \
1737 case LEX_INTERPCASEMOD:
1739 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1740 croak("panic: INTERPCASEMOD");
1742 /* handle \E or end of string */
1743 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1747 if (PL_lex_casemods) {
1748 oldmod = PL_lex_casestack[--PL_lex_casemods];
1749 PL_lex_casestack[PL_lex_casemods] = '\0';
1751 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1753 PL_lex_state = LEX_INTERPCONCAT;
1757 if (PL_bufptr != PL_bufend)
1759 PL_lex_state = LEX_INTERPCONCAT;
1760 return yylex(PERL_YYLEX_PARAM);
1764 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1765 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1766 if (strchr("LU", *s) &&
1767 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1769 PL_lex_casestack[--PL_lex_casemods] = '\0';
1772 if (PL_lex_casemods > 10) {
1773 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1774 if (newlb != PL_lex_casestack) {
1776 PL_lex_casestack = newlb;
1779 PL_lex_casestack[PL_lex_casemods++] = *s;
1780 PL_lex_casestack[PL_lex_casemods] = '\0';
1781 PL_lex_state = LEX_INTERPCONCAT;
1782 PL_nextval[PL_nexttoke].ival = 0;
1785 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1787 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1789 PL_nextval[PL_nexttoke].ival = OP_LC;
1791 PL_nextval[PL_nexttoke].ival = OP_UC;
1793 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1795 croak("panic: yylex");
1798 if (PL_lex_starts) {
1804 return yylex(PERL_YYLEX_PARAM);
1807 case LEX_INTERPPUSH:
1808 return sublex_push();
1810 case LEX_INTERPSTART:
1811 if (PL_bufptr == PL_bufend)
1812 return sublex_done();
1814 PL_lex_dojoin = (*PL_bufptr == '@');
1815 PL_lex_state = LEX_INTERPNORMAL;
1816 if (PL_lex_dojoin) {
1817 PL_nextval[PL_nexttoke].ival = 0;
1820 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1821 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1822 force_next(PRIVATEREF);
1824 force_ident("\"", '$');
1825 #endif /* USE_THREADS */
1826 PL_nextval[PL_nexttoke].ival = 0;
1828 PL_nextval[PL_nexttoke].ival = 0;
1830 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1833 if (PL_lex_starts++) {
1837 return yylex(PERL_YYLEX_PARAM);
1839 case LEX_INTERPENDMAYBE:
1840 if (intuit_more(PL_bufptr)) {
1841 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1847 if (PL_lex_dojoin) {
1848 PL_lex_dojoin = FALSE;
1849 PL_lex_state = LEX_INTERPCONCAT;
1852 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl && SvCOMPILED(PL_lex_repl)) {
1853 if (PL_bufptr != PL_bufend)
1854 croak("Bad evalled substitution pattern");
1855 PL_lex_repl = Nullsv;
1858 case LEX_INTERPCONCAT:
1860 if (PL_lex_brackets)
1861 croak("panic: INTERPCONCAT");
1863 if (PL_bufptr == PL_bufend)
1864 return sublex_done();
1866 if (SvIVX(PL_linestr) == '\'') {
1867 SV *sv = newSVsv(PL_linestr);
1870 else if ( PL_hints & HINT_NEW_RE )
1871 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1872 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1876 s = scan_const(PL_bufptr);
1878 PL_lex_state = LEX_INTERPCASEMOD;
1880 PL_lex_state = LEX_INTERPSTART;
1883 if (s != PL_bufptr) {
1884 PL_nextval[PL_nexttoke] = yylval;
1887 if (PL_lex_starts++)
1891 return yylex(PERL_YYLEX_PARAM);
1895 return yylex(PERL_YYLEX_PARAM);
1897 PL_lex_state = LEX_NORMAL;
1898 s = scan_formline(PL_bufptr);
1899 if (!PL_lex_formbrack)
1905 PL_oldoldbufptr = PL_oldbufptr;
1908 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1914 if (isIDFIRST_lazy(s))
1916 croak("Unrecognized character \\x%02X", *s & 255);
1919 goto fake_eof; /* emulate EOF on ^D or ^Z */
1924 if (PL_lex_brackets)
1925 yyerror("Missing right bracket");
1928 if (s++ < PL_bufend)
1929 goto retry; /* ignore stray nulls */
1932 if (!PL_in_eval && !PL_preambled) {
1933 PL_preambled = TRUE;
1934 sv_setpv(PL_linestr,incl_perldb());
1935 if (SvCUR(PL_linestr))
1936 sv_catpv(PL_linestr,";");
1938 while(AvFILLp(PL_preambleav) >= 0) {
1939 SV *tmpsv = av_shift(PL_preambleav);
1940 sv_catsv(PL_linestr, tmpsv);
1941 sv_catpv(PL_linestr, ";");
1944 sv_free((SV*)PL_preambleav);
1945 PL_preambleav = NULL;
1947 if (PL_minus_n || PL_minus_p) {
1948 sv_catpv(PL_linestr, "LINE: while (<>) {");
1950 sv_catpv(PL_linestr,"chomp;");
1952 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1954 GvIMPORTED_AV_on(gv);
1956 if (strchr("/'\"", *PL_splitstr)
1957 && strchr(PL_splitstr + 1, *PL_splitstr))
1958 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1961 s = "'~#\200\1'"; /* surely one char is unused...*/
1962 while (s[1] && strchr(PL_splitstr, *s)) s++;
1964 sv_catpvf(PL_linestr, "@F=split(%s%c",
1965 "q" + (delim == '\''), delim);
1966 for (s = PL_splitstr; *s; s++) {
1968 sv_catpvn(PL_linestr, "\\", 1);
1969 sv_catpvn(PL_linestr, s, 1);
1971 sv_catpvf(PL_linestr, "%c);", delim);
1975 sv_catpv(PL_linestr,"@F=split(' ');");
1978 sv_catpv(PL_linestr, "\n");
1979 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1980 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1981 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1982 SV *sv = NEWSV(85,0);
1984 sv_upgrade(sv, SVt_PVMG);
1985 sv_setsv(sv,PL_linestr);
1986 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1991 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1994 if (PL_preprocess && !PL_in_eval)
1995 (void)PerlProc_pclose(PL_rsfp);
1996 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1997 PerlIO_clearerr(PL_rsfp);
1999 (void)PerlIO_close(PL_rsfp);
2001 PL_doextract = FALSE;
2003 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2004 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2005 sv_catpv(PL_linestr,";}");
2006 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2007 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2008 PL_minus_n = PL_minus_p = 0;
2011 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2012 sv_setpv(PL_linestr,"");
2013 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2016 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2017 PL_doextract = FALSE;
2019 /* Incest with pod. */
2020 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2021 sv_setpv(PL_linestr, "");
2022 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2023 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2024 PL_doextract = FALSE;
2028 } while (PL_doextract);
2029 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2030 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2031 SV *sv = NEWSV(85,0);
2033 sv_upgrade(sv, SVt_PVMG);
2034 sv_setsv(sv,PL_linestr);
2035 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2037 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2038 if (PL_curcop->cop_line == 1) {
2039 while (s < PL_bufend && isSPACE(*s))
2041 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2045 if (*s == '#' && *(s+1) == '!')
2047 #ifdef ALTERNATE_SHEBANG
2049 static char as[] = ALTERNATE_SHEBANG;
2050 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2051 d = s + (sizeof(as) - 1);
2053 #endif /* ALTERNATE_SHEBANG */
2062 while (*d && !isSPACE(*d))
2066 #ifdef ARG_ZERO_IS_SCRIPT
2067 if (ipathend > ipath) {
2069 * HP-UX (at least) sets argv[0] to the script name,
2070 * which makes $^X incorrect. And Digital UNIX and Linux,
2071 * at least, set argv[0] to the basename of the Perl
2072 * interpreter. So, having found "#!", we'll set it right.
2074 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2075 assert(SvPOK(x) || SvGMAGICAL(x));
2076 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2077 sv_setpvn(x, ipath, ipathend - ipath);
2080 TAINT_NOT; /* $^X is always tainted, but that's OK */
2082 #endif /* ARG_ZERO_IS_SCRIPT */
2087 d = instr(s,"perl -");
2089 d = instr(s,"perl");
2090 #ifdef ALTERNATE_SHEBANG
2092 * If the ALTERNATE_SHEBANG on this system starts with a
2093 * character that can be part of a Perl expression, then if
2094 * we see it but not "perl", we're probably looking at the
2095 * start of Perl code, not a request to hand off to some
2096 * other interpreter. Similarly, if "perl" is there, but
2097 * not in the first 'word' of the line, we assume the line
2098 * contains the start of the Perl program.
2100 if (d && *s != '#') {
2102 while (*c && !strchr("; \t\r\n\f\v#", *c))
2105 d = Nullch; /* "perl" not in first word; ignore */
2107 *s = '#'; /* Don't try to parse shebang line */
2109 #endif /* ALTERNATE_SHEBANG */
2114 !instr(s,"indir") &&
2115 instr(PL_origargv[0],"perl"))
2121 while (s < PL_bufend && isSPACE(*s))
2123 if (s < PL_bufend) {
2124 Newz(899,newargv,PL_origargc+3,char*);
2126 while (s < PL_bufend && !isSPACE(*s))
2129 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2132 newargv = PL_origargv;
2134 PerlProc_execv(ipath, newargv);
2135 croak("Can't exec %s", ipath);
2138 U32 oldpdb = PL_perldb;
2139 bool oldn = PL_minus_n;
2140 bool oldp = PL_minus_p;
2142 while (*d && !isSPACE(*d)) d++;
2143 while (*d == ' ' || *d == '\t') d++;
2147 if (*d == 'M' || *d == 'm') {
2149 while (*d && !isSPACE(*d)) d++;
2150 croak("Too late for \"-%.*s\" option",
2153 d = moreswitches(d);
2155 if (PERLDB_LINE && !oldpdb ||
2156 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2157 /* if we have already added "LINE: while (<>) {",
2158 we must not do it again */
2160 sv_setpv(PL_linestr, "");
2161 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2162 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2163 PL_preambled = FALSE;
2165 (void)gv_fetchfile(PL_origfilename);
2172 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2174 PL_lex_state = LEX_FORMLINE;
2175 return yylex(PERL_YYLEX_PARAM);
2179 #ifdef PERL_STRICT_CR
2180 warn("Illegal character \\%03o (carriage return)", '\r');
2182 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2184 case ' ': case '\t': case '\f': case 013:
2189 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2191 while (s < d && *s != '\n')
2196 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2198 PL_lex_state = LEX_FORMLINE;
2199 return yylex(PERL_YYLEX_PARAM);
2208 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2213 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2216 if (strnEQ(s,"=>",2)) {
2217 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2218 OPERATOR('-'); /* unary minus */
2220 PL_last_uni = PL_oldbufptr;
2221 PL_last_lop_op = OP_FTEREAD; /* good enough */
2223 case 'r': FTST(OP_FTEREAD);
2224 case 'w': FTST(OP_FTEWRITE);
2225 case 'x': FTST(OP_FTEEXEC);
2226 case 'o': FTST(OP_FTEOWNED);
2227 case 'R': FTST(OP_FTRREAD);
2228 case 'W': FTST(OP_FTRWRITE);
2229 case 'X': FTST(OP_FTREXEC);
2230 case 'O': FTST(OP_FTROWNED);
2231 case 'e': FTST(OP_FTIS);
2232 case 'z': FTST(OP_FTZERO);
2233 case 's': FTST(OP_FTSIZE);
2234 case 'f': FTST(OP_FTFILE);
2235 case 'd': FTST(OP_FTDIR);
2236 case 'l': FTST(OP_FTLINK);
2237 case 'p': FTST(OP_FTPIPE);
2238 case 'S': FTST(OP_FTSOCK);
2239 case 'u': FTST(OP_FTSUID);
2240 case 'g': FTST(OP_FTSGID);
2241 case 'k': FTST(OP_FTSVTX);
2242 case 'b': FTST(OP_FTBLK);
2243 case 'c': FTST(OP_FTCHR);
2244 case 't': FTST(OP_FTTTY);
2245 case 'T': FTST(OP_FTTEXT);
2246 case 'B': FTST(OP_FTBINARY);
2247 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2248 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2249 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2251 croak("Unrecognized file test: -%c", (int)tmp);
2258 if (PL_expect == XOPERATOR)
2263 else if (*s == '>') {
2266 if (isIDFIRST_lazy(s)) {
2267 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2275 if (PL_expect == XOPERATOR)
2278 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2280 OPERATOR('-'); /* unary minus */
2287 if (PL_expect == XOPERATOR)
2292 if (PL_expect == XOPERATOR)
2295 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2301 if (PL_expect != XOPERATOR) {
2302 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2303 PL_expect = XOPERATOR;
2304 force_ident(PL_tokenbuf, '*');
2317 if (PL_expect == XOPERATOR) {
2321 PL_tokenbuf[0] = '%';
2322 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2323 if (!PL_tokenbuf[1]) {
2325 yyerror("Final % should be \\% or %name");
2328 PL_pending_ident = '%';
2350 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2351 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2356 if (PL_curcop->cop_line < PL_copline)
2357 PL_copline = PL_curcop->cop_line;
2368 if (PL_lex_brackets <= 0)
2369 yyerror("Unmatched right bracket");
2372 if (PL_lex_state == LEX_INTERPNORMAL) {
2373 if (PL_lex_brackets == 0) {
2374 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2375 PL_lex_state = LEX_INTERPEND;
2382 if (PL_lex_brackets > 100) {
2383 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2384 if (newlb != PL_lex_brackstack) {
2386 PL_lex_brackstack = newlb;
2389 switch (PL_expect) {
2391 if (PL_lex_formbrack) {
2395 if (PL_oldoldbufptr == PL_last_lop)
2396 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2398 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2399 OPERATOR(HASHBRACK);
2401 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2404 PL_tokenbuf[0] = '\0';
2405 if (d < PL_bufend && *d == '-') {
2406 PL_tokenbuf[0] = '-';
2408 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2411 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2412 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2414 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2417 char minus = (PL_tokenbuf[0] == '-');
2418 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2425 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2429 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2434 if (PL_oldoldbufptr == PL_last_lop)
2435 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2437 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2440 OPERATOR(HASHBRACK);
2441 /* This hack serves to disambiguate a pair of curlies
2442 * as being a block or an anon hash. Normally, expectation
2443 * determines that, but in cases where we're not in a
2444 * position to expect anything in particular (like inside
2445 * eval"") we have to resolve the ambiguity. This code
2446 * covers the case where the first term in the curlies is a
2447 * quoted string. Most other cases need to be explicitly
2448 * disambiguated by prepending a `+' before the opening
2449 * curly in order to force resolution as an anon hash.
2451 * XXX should probably propagate the outer expectation
2452 * into eval"" to rely less on this hack, but that could
2453 * potentially break current behavior of eval"".
2457 if (*s == '\'' || *s == '"' || *s == '`') {
2458 /* common case: get past first string, handling escapes */
2459 for (t++; t < PL_bufend && *t != *s;)
2460 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2464 else if (*s == 'q') {
2467 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2468 && !isALNUM(*t)))) {
2470 char open, close, term;
2473 while (t < PL_bufend && isSPACE(*t))
2477 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2481 for (t++; t < PL_bufend; t++) {
2482 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2484 else if (*t == open)
2488 for (t++; t < PL_bufend; t++) {
2489 if (*t == '\\' && t+1 < PL_bufend)
2491 else if (*t == close && --brackets <= 0)
2493 else if (*t == open)
2499 else if (isIDFIRST_lazy(s)) {
2500 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2502 while (t < PL_bufend && isSPACE(*t))
2504 /* if comma follows first term, call it an anon hash */
2505 /* XXX it could be a comma expression with loop modifiers */
2506 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2507 || (*t == '=' && t[1] == '>')))
2508 OPERATOR(HASHBRACK);
2509 if (PL_expect == XREF)
2510 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2512 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2518 yylval.ival = PL_curcop->cop_line;
2519 if (isSPACE(*s) || *s == '#')
2520 PL_copline = NOLINE; /* invalidate current command line number */
2525 if (PL_lex_brackets <= 0)
2526 yyerror("Unmatched right bracket");
2528 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2529 if (PL_lex_brackets < PL_lex_formbrack)
2530 PL_lex_formbrack = 0;
2531 if (PL_lex_state == LEX_INTERPNORMAL) {
2532 if (PL_lex_brackets == 0) {
2533 if (PL_lex_fakebrack) {
2534 PL_lex_state = LEX_INTERPEND;
2536 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2538 if (*s == '-' && s[1] == '>')
2539 PL_lex_state = LEX_INTERPENDMAYBE;
2540 else if (*s != '[' && *s != '{')
2541 PL_lex_state = LEX_INTERPEND;
2544 if (PL_lex_brackets < PL_lex_fakebrack) {
2546 PL_lex_fakebrack = 0;
2547 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2557 if (PL_expect == XOPERATOR) {
2558 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2559 PL_curcop->cop_line--;
2560 warner(WARN_SEMICOLON, PL_warn_nosemi);
2561 PL_curcop->cop_line++;
2566 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2568 PL_expect = XOPERATOR;
2569 force_ident(PL_tokenbuf, '&');
2573 yylval.ival = (OPpENTERSUB_AMPER<<8);
2592 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2593 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2595 if (PL_expect == XSTATE && isALPHA(tmp) &&
2596 (s == PL_linestart+1 || s[-2] == '\n') )
2598 if (PL_in_eval && !PL_rsfp) {
2603 if (strnEQ(s,"=cut",4)) {
2617 PL_doextract = TRUE;
2620 if (PL_lex_brackets < PL_lex_formbrack) {
2622 #ifdef PERL_STRICT_CR
2623 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2625 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2627 if (*t == '\n' || *t == '#') {
2645 if (PL_expect != XOPERATOR) {
2646 if (s[1] != '<' && !strchr(s,'>'))
2649 s = scan_heredoc(s);
2651 s = scan_inputsymbol(s);
2652 TERM(sublex_start());
2657 SHop(OP_LEFT_SHIFT);
2671 SHop(OP_RIGHT_SHIFT);
2680 if (PL_expect == XOPERATOR) {
2681 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2684 return ','; /* grandfather non-comma-format format */
2688 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2689 if (PL_expect == XOPERATOR)
2690 no_op("Array length", PL_bufptr);
2691 PL_tokenbuf[0] = '@';
2692 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2694 if (!PL_tokenbuf[1])
2696 PL_expect = XOPERATOR;
2697 PL_pending_ident = '#';
2701 if (PL_expect == XOPERATOR)
2702 no_op("Scalar", PL_bufptr);
2703 PL_tokenbuf[0] = '$';
2704 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2705 if (!PL_tokenbuf[1]) {
2707 yyerror("Final $ should be \\$ or $name");
2711 /* This kludge not intended to be bulletproof. */
2712 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2713 yylval.opval = newSVOP(OP_CONST, 0,
2714 newSViv((IV)PL_compiling.cop_arybase));
2715 yylval.opval->op_private = OPpCONST_ARYBASE;
2720 if (PL_lex_state == LEX_NORMAL)
2723 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2726 PL_tokenbuf[0] = '@';
2727 if (ckWARN(WARN_SYNTAX)) {
2729 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2732 PL_bufptr = skipspace(PL_bufptr);
2733 while (t < PL_bufend && *t != ']')
2736 "Multidimensional syntax %.*s not supported",
2737 (t - PL_bufptr) + 1, PL_bufptr);
2741 else if (*s == '{') {
2742 PL_tokenbuf[0] = '%';
2743 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2744 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2746 char tmpbuf[sizeof PL_tokenbuf];
2748 for (t++; isSPACE(*t); t++) ;
2749 if (isIDFIRST_lazy(t)) {
2750 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2751 for (; isSPACE(*t); t++) ;
2752 if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
2754 "You need to quote \"%s\"", tmpbuf);
2760 PL_expect = XOPERATOR;
2761 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2762 bool islop = (PL_last_lop == PL_oldoldbufptr);
2763 if (!islop || PL_last_lop_op == OP_GREPSTART)
2764 PL_expect = XOPERATOR;
2765 else if (strchr("$@\"'`q", *s))
2766 PL_expect = XTERM; /* e.g. print $fh "foo" */
2767 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2768 PL_expect = XTERM; /* e.g. print $fh &sub */
2769 else if (isIDFIRST_lazy(s)) {
2770 char tmpbuf[sizeof PL_tokenbuf];
2771 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2772 if (tmp = keyword(tmpbuf, len)) {
2773 /* binary operators exclude handle interpretations */
2785 PL_expect = XTERM; /* e.g. print $fh length() */
2790 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2791 if (gv && GvCVu(gv))
2792 PL_expect = XTERM; /* e.g. print $fh subr() */
2795 else if (isDIGIT(*s))
2796 PL_expect = XTERM; /* e.g. print $fh 3 */
2797 else if (*s == '.' && isDIGIT(s[1]))
2798 PL_expect = XTERM; /* e.g. print $fh .3 */
2799 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2800 PL_expect = XTERM; /* e.g. print $fh -1 */
2801 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2802 PL_expect = XTERM; /* print $fh <<"EOF" */
2804 PL_pending_ident = '$';
2808 if (PL_expect == XOPERATOR)
2810 PL_tokenbuf[0] = '@';
2811 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2812 if (!PL_tokenbuf[1]) {
2814 yyerror("Final @ should be \\@ or @name");
2817 if (PL_lex_state == LEX_NORMAL)
2819 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2821 PL_tokenbuf[0] = '%';
2823 /* Warn about @ where they meant $. */
2824 if (ckWARN(WARN_SYNTAX)) {
2825 if (*s == '[' || *s == '{') {
2827 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2829 if (*t == '}' || *t == ']') {
2831 PL_bufptr = skipspace(PL_bufptr);
2833 "Scalar value %.*s better written as $%.*s",
2834 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2839 PL_pending_ident = '@';
2842 case '/': /* may either be division or pattern */
2843 case '?': /* may either be conditional or pattern */
2844 if (PL_expect != XOPERATOR) {
2845 /* Disable warning on "study /blah/" */
2846 if (PL_oldoldbufptr == PL_last_uni
2847 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2848 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2850 s = scan_pat(s,OP_MATCH);
2851 TERM(sublex_start());
2859 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2860 #ifdef PERL_STRICT_CR
2863 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2865 && (s == PL_linestart || s[-1] == '\n') )
2867 PL_lex_formbrack = 0;
2871 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2877 yylval.ival = OPf_SPECIAL;
2883 if (PL_expect != XOPERATOR)
2888 case '0': case '1': case '2': case '3': case '4':
2889 case '5': case '6': case '7': case '8': case '9':
2891 if (PL_expect == XOPERATOR)
2897 if (PL_expect == XOPERATOR) {
2898 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2901 return ','; /* grandfather non-comma-format format */
2907 missingterm((char*)0);
2908 yylval.ival = OP_CONST;
2909 TERM(sublex_start());
2913 if (PL_expect == XOPERATOR) {
2914 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2917 return ','; /* grandfather non-comma-format format */
2923 missingterm((char*)0);
2924 yylval.ival = OP_CONST;
2925 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2926 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2927 yylval.ival = OP_STRINGIFY;
2931 TERM(sublex_start());
2935 if (PL_expect == XOPERATOR)
2936 no_op("Backticks",s);
2938 missingterm((char*)0);
2939 yylval.ival = OP_BACKTICK;
2941 TERM(sublex_start());
2945 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2946 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2948 if (PL_expect == XOPERATOR)
2949 no_op("Backslash",s);
2953 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2993 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2995 /* Some keywords can be followed by any delimiter, including ':' */
2996 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2997 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2998 (PL_tokenbuf[0] == 'q' &&
2999 strchr("qwxr", PL_tokenbuf[1]))));
3001 /* x::* is just a word, unless x is "CORE" */
3002 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3006 while (d < PL_bufend && isSPACE(*d))
3007 d++; /* no comments skipped here, or s### is misparsed */
3009 /* Is this a label? */
3010 if (!tmp && PL_expect == XSTATE
3011 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3013 yylval.pval = savepv(PL_tokenbuf);
3018 /* Check for keywords */
3019 tmp = keyword(PL_tokenbuf, len);
3021 /* Is this a word before a => operator? */
3022 if (strnEQ(d,"=>",2)) {
3024 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3025 yylval.opval->op_private = OPpCONST_BARE;
3029 if (tmp < 0) { /* second-class keyword? */
3030 GV *ogv = Nullgv; /* override (winner) */
3031 GV *hgv = Nullgv; /* hidden (loser) */
3032 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3034 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3037 if (GvIMPORTED_CV(gv))
3039 else if (! CvMETHOD(cv))
3043 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3044 (gv = *gvp) != (GV*)&PL_sv_undef &&
3045 GvCVu(gv) && GvIMPORTED_CV(gv))
3051 tmp = 0; /* overridden by import or by GLOBAL */
3054 && -tmp==KEY_lock /* XXX generalizable kludge */
3055 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3057 tmp = 0; /* any sub overrides "weak" keyword */
3059 else { /* no override */
3063 if (ckWARN(WARN_AMBIGUOUS) && hgv
3064 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3065 warner(WARN_AMBIGUOUS,
3066 "Ambiguous call resolved as CORE::%s(), %s",
3067 GvENAME(hgv), "qualify as such or use &");
3074 default: /* not a keyword */
3077 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3079 /* Get the rest if it looks like a package qualifier */
3081 if (*s == '\'' || *s == ':' && s[1] == ':') {
3083 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3086 croak("Bad name after %s%s", PL_tokenbuf,
3087 *s == '\'' ? "'" : "::");
3091 if (PL_expect == XOPERATOR) {
3092 if (PL_bufptr == PL_linestart) {
3093 PL_curcop->cop_line--;
3094 warner(WARN_SEMICOLON, PL_warn_nosemi);
3095 PL_curcop->cop_line++;
3098 no_op("Bareword",s);
3101 /* Look for a subroutine with this name in current package,
3102 unless name is "Foo::", in which case Foo is a bearword
3103 (and a package name). */
3106 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3108 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3110 "Bareword \"%s\" refers to nonexistent package",
3113 PL_tokenbuf[len] = '\0';
3120 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3123 /* if we saw a global override before, get the right name */
3126 sv = newSVpv("CORE::GLOBAL::",14);
3127 sv_catpv(sv,PL_tokenbuf);
3130 sv = newSVpv(PL_tokenbuf,0);
3132 /* Presume this is going to be a bareword of some sort. */
3135 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3136 yylval.opval->op_private = OPpCONST_BARE;
3138 /* And if "Foo::", then that's what it certainly is. */
3143 /* See if it's the indirect object for a list operator. */
3145 if (PL_oldoldbufptr &&
3146 PL_oldoldbufptr < PL_bufptr &&
3147 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3148 /* NO SKIPSPACE BEFORE HERE! */
3150 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3151 || (PL_last_lop_op == OP_ENTERSUB
3153 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3155 bool immediate_paren = *s == '(';
3157 /* (Now we can afford to cross potential line boundary.) */
3160 /* Two barewords in a row may indicate method call. */
3162 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3165 /* If not a declared subroutine, it's an indirect object. */
3166 /* (But it's an indir obj regardless for sort.) */
3168 if ((PL_last_lop_op == OP_SORT ||
3169 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3170 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3171 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3176 /* If followed by a paren, it's certainly a subroutine. */
3178 PL_expect = XOPERATOR;
3182 if (gv && GvCVu(gv)) {
3184 if ((cv = GvCV(gv)) && SvPOK(cv))
3185 PL_last_proto = SvPV((SV*)cv, n_a);
3186 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3187 if (*d == ')' && (sv = cv_const_sv(cv))) {
3192 PL_nextval[PL_nexttoke].opval = yylval.opval;
3193 PL_expect = XOPERATOR;
3196 PL_last_lop_op = OP_ENTERSUB;
3200 /* If followed by var or block, call it a method (unless sub) */
3202 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3203 PL_last_lop = PL_oldbufptr;
3204 PL_last_lop_op = OP_METHOD;
3208 /* If followed by a bareword, see if it looks like indir obj. */
3210 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3213 /* Not a method, so call it a subroutine (if defined) */
3215 if (gv && GvCVu(gv)) {
3217 if (lastchar == '-')
3218 warn("Ambiguous use of -%s resolved as -&%s()",
3219 PL_tokenbuf, PL_tokenbuf);
3220 PL_last_lop = PL_oldbufptr;
3221 PL_last_lop_op = OP_ENTERSUB;
3222 /* Check for a constant sub */
3224 if ((sv = cv_const_sv(cv))) {
3226 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3227 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3228 yylval.opval->op_private = 0;
3232 /* Resolve to GV now. */
3233 op_free(yylval.opval);
3234 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3235 PL_last_lop_op = OP_ENTERSUB;
3236 /* Is there a prototype? */
3239 PL_last_proto = SvPV((SV*)cv, len);
3242 if (strEQ(PL_last_proto, "$"))
3244 if (*PL_last_proto == '&' && *s == '{') {
3245 sv_setpv(PL_subname,"__ANON__");
3249 PL_last_proto = NULL;
3250 PL_nextval[PL_nexttoke].opval = yylval.opval;
3256 if (PL_hints & HINT_STRICT_SUBS &&
3259 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3260 PL_last_lop_op != OP_ACCEPT &&
3261 PL_last_lop_op != OP_PIPE_OP &&
3262 PL_last_lop_op != OP_SOCKPAIR &&
3263 !(PL_last_lop_op == OP_ENTERSUB
3265 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3268 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3273 /* Call it a bare word */
3276 if (ckWARN(WARN_RESERVED)) {
3277 if (lastchar != '-') {
3278 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3280 warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
3285 if (lastchar && strchr("*%&", lastchar)) {
3286 warn("Operator or semicolon missing before %c%s",
3287 lastchar, PL_tokenbuf);
3288 warn("Ambiguous use of %c resolved as operator %c",
3289 lastchar, lastchar);
3295 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3296 newSVsv(GvSV(PL_curcop->cop_filegv)));
3300 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3301 newSVpvf("%ld", (long)PL_curcop->cop_line));
3304 case KEY___PACKAGE__:
3305 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3307 ? newSVsv(PL_curstname)
3316 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3317 char *pname = "main";
3318 if (PL_tokenbuf[2] == 'D')
3319 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3320 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3323 GvIOp(gv) = newIO();
3324 IoIFP(GvIOp(gv)) = PL_rsfp;
3325 #if defined(HAS_FCNTL) && defined(F_SETFD)
3327 int fd = PerlIO_fileno(PL_rsfp);
3328 fcntl(fd,F_SETFD,fd >= 3);
3331 /* Mark this internal pseudo-handle as clean */
3332 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3334 IoTYPE(GvIOp(gv)) = '|';
3335 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3336 IoTYPE(GvIOp(gv)) = '-';
3338 IoTYPE(GvIOp(gv)) = '<';
3349 if (PL_expect == XSTATE) {
3356 if (*s == ':' && s[1] == ':') {
3359 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3360 tmp = keyword(PL_tokenbuf, len);
3374 LOP(OP_ACCEPT,XTERM);
3380 LOP(OP_ATAN2,XTERM);
3389 LOP(OP_BLESS,XTERM);
3398 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3415 if (!PL_cryptseen++)
3418 LOP(OP_CRYPT,XTERM);
3421 if (ckWARN(WARN_OCTAL)) {
3422 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3423 if (*d != '0' && isDIGIT(*d))
3424 yywarn("chmod: mode argument is missing initial 0");
3426 LOP(OP_CHMOD,XTERM);
3429 LOP(OP_CHOWN,XTERM);
3432 LOP(OP_CONNECT,XTERM);
3448 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3452 PL_hints |= HINT_BLOCK_SCOPE;
3462 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3463 LOP(OP_DBMOPEN,XTERM);
3469 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3476 yylval.ival = PL_curcop->cop_line;
3490 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3491 UNIBRACK(OP_ENTEREVAL);
3506 case KEY_endhostent:
3512 case KEY_endservent:
3515 case KEY_endprotoent:
3526 yylval.ival = PL_curcop->cop_line;
3528 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3530 if ((PL_bufend - p) >= 3 &&
3531 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3534 if (isIDFIRST_lazy(p))
3535 croak("Missing $ on loop variable");
3540 LOP(OP_FORMLINE,XTERM);
3546 LOP(OP_FCNTL,XTERM);
3552 LOP(OP_FLOCK,XTERM);
3561 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3564 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3579 case KEY_getpriority:
3580 LOP(OP_GETPRIORITY,XTERM);
3582 case KEY_getprotobyname:
3585 case KEY_getprotobynumber:
3586 LOP(OP_GPBYNUMBER,XTERM);
3588 case KEY_getprotoent:
3600 case KEY_getpeername:
3601 UNI(OP_GETPEERNAME);
3603 case KEY_gethostbyname:
3606 case KEY_gethostbyaddr:
3607 LOP(OP_GHBYADDR,XTERM);
3609 case KEY_gethostent:
3612 case KEY_getnetbyname:
3615 case KEY_getnetbyaddr:
3616 LOP(OP_GNBYADDR,XTERM);
3621 case KEY_getservbyname:
3622 LOP(OP_GSBYNAME,XTERM);
3624 case KEY_getservbyport:
3625 LOP(OP_GSBYPORT,XTERM);
3627 case KEY_getservent:
3630 case KEY_getsockname:
3631 UNI(OP_GETSOCKNAME);
3633 case KEY_getsockopt:
3634 LOP(OP_GSOCKOPT,XTERM);
3656 yylval.ival = PL_curcop->cop_line;
3660 LOP(OP_INDEX,XTERM);
3666 LOP(OP_IOCTL,XTERM);
3678 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3709 LOP(OP_LISTEN,XTERM);
3718 s = scan_pat(s,OP_MATCH);
3719 TERM(sublex_start());
3722 LOP(OP_MAPSTART, XREF);
3725 LOP(OP_MKDIR,XTERM);
3728 LOP(OP_MSGCTL,XTERM);
3731 LOP(OP_MSGGET,XTERM);
3734 LOP(OP_MSGRCV,XTERM);
3737 LOP(OP_MSGSND,XTERM);
3742 if (isIDFIRST_lazy(s)) {
3743 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3744 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3745 if (!PL_in_my_stash) {
3748 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3755 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3762 if (PL_expect != XSTATE)
3763 yyerror("\"no\" not allowed in expression");
3764 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3765 s = force_version(s);
3774 if (isIDFIRST_lazy(s)) {
3776 for (d = s; isALNUM_lazy(d); d++) ;
3778 if (strchr("|&*+-=!?:.", *t))
3779 warn("Precedence problem: open %.*s should be open(%.*s)",
3785 yylval.ival = OP_OR;
3795 LOP(OP_OPEN_DIR,XTERM);
3798 checkcomma(s,PL_tokenbuf,"filehandle");
3802 checkcomma(s,PL_tokenbuf,"filehandle");
3821 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3825 LOP(OP_PIPE_OP,XTERM);
3830 missingterm((char*)0);
3831 yylval.ival = OP_CONST;
3832 TERM(sublex_start());
3840 missingterm((char*)0);
3842 if (SvCUR(PL_lex_stuff)) {
3845 d = SvPV_force(PL_lex_stuff, len);
3847 for (; isSPACE(*d) && len; --len, ++d) ;
3850 if (!warned && ckWARN(WARN_SYNTAX)) {
3851 for (; !isSPACE(*d) && len; --len, ++d) {
3854 "Possible attempt to separate words with commas");
3857 else if (*d == '#') {
3859 "Possible attempt to put comments in qw() list");
3865 for (; !isSPACE(*d) && len; --len, ++d) ;
3867 words = append_elem(OP_LIST, words,
3868 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
3872 PL_nextval[PL_nexttoke].opval = words;
3877 SvREFCNT_dec(PL_lex_stuff);
3878 PL_lex_stuff = Nullsv;
3885 missingterm((char*)0);
3886 yylval.ival = OP_STRINGIFY;
3887 if (SvIVX(PL_lex_stuff) == '\'')
3888 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3889 TERM(sublex_start());
3892 s = scan_pat(s,OP_QR);
3893 TERM(sublex_start());
3898 missingterm((char*)0);
3899 yylval.ival = OP_BACKTICK;
3901 TERM(sublex_start());
3907 *PL_tokenbuf = '\0';
3908 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3909 if (isIDFIRST_lazy(PL_tokenbuf))
3910 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3912 yyerror("<> should be quotes");
3919 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3923 LOP(OP_RENAME,XTERM);
3932 LOP(OP_RINDEX,XTERM);
3955 LOP(OP_REVERSE,XTERM);
3966 TERM(sublex_start());
3968 TOKEN(1); /* force error */
3977 LOP(OP_SELECT,XTERM);
3983 LOP(OP_SEMCTL,XTERM);
3986 LOP(OP_SEMGET,XTERM);
3989 LOP(OP_SEMOP,XTERM);
3995 LOP(OP_SETPGRP,XTERM);
3997 case KEY_setpriority:
3998 LOP(OP_SETPRIORITY,XTERM);
4000 case KEY_sethostent:
4006 case KEY_setservent:
4009 case KEY_setprotoent:
4019 LOP(OP_SEEKDIR,XTERM);
4021 case KEY_setsockopt:
4022 LOP(OP_SSOCKOPT,XTERM);
4028 LOP(OP_SHMCTL,XTERM);
4031 LOP(OP_SHMGET,XTERM);
4034 LOP(OP_SHMREAD,XTERM);
4037 LOP(OP_SHMWRITE,XTERM);
4040 LOP(OP_SHUTDOWN,XTERM);
4049 LOP(OP_SOCKET,XTERM);
4051 case KEY_socketpair:
4052 LOP(OP_SOCKPAIR,XTERM);
4055 checkcomma(s,PL_tokenbuf,"subroutine name");
4057 if (*s == ';' || *s == ')') /* probably a close */
4058 croak("sort is now a reserved word");
4060 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4064 LOP(OP_SPLIT,XTERM);
4067 LOP(OP_SPRINTF,XTERM);
4070 LOP(OP_SPLICE,XTERM);
4086 LOP(OP_SUBSTR,XTERM);
4093 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4094 char tmpbuf[sizeof PL_tokenbuf];
4096 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4097 if (strchr(tmpbuf, ':'))
4098 sv_setpv(PL_subname, tmpbuf);
4100 sv_setsv(PL_subname,PL_curstname);
4101 sv_catpvn(PL_subname,"::",2);
4102 sv_catpvn(PL_subname,tmpbuf,len);
4104 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4108 PL_expect = XTERMBLOCK;
4109 sv_setpv(PL_subname,"?");
4112 if (tmp == KEY_format) {
4115 PL_lex_formbrack = PL_lex_brackets + 1;
4119 /* Look for a prototype */
4126 SvREFCNT_dec(PL_lex_stuff);
4127 PL_lex_stuff = Nullsv;
4128 croak("Prototype not terminated");
4131 d = SvPVX(PL_lex_stuff);
4133 for (p = d; *p; ++p) {
4138 SvCUR(PL_lex_stuff) = tmp;
4141 PL_nextval[1] = PL_nextval[0];
4142 PL_nexttype[1] = PL_nexttype[0];
4143 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4144 PL_nexttype[0] = THING;
4145 if (PL_nexttoke == 1) {
4146 PL_lex_defer = PL_lex_state;
4147 PL_lex_expect = PL_expect;
4148 PL_lex_state = LEX_KNOWNEXT;
4150 PL_lex_stuff = Nullsv;
4153 if (*SvPV(PL_subname,n_a) == '?') {
4154 sv_setpv(PL_subname,"__ANON__");
4161 LOP(OP_SYSTEM,XREF);
4164 LOP(OP_SYMLINK,XTERM);
4167 LOP(OP_SYSCALL,XTERM);
4170 LOP(OP_SYSOPEN,XTERM);
4173 LOP(OP_SYSSEEK,XTERM);
4176 LOP(OP_SYSREAD,XTERM);
4179 LOP(OP_SYSWRITE,XTERM);
4183 TERM(sublex_start());
4204 LOP(OP_TRUNCATE,XTERM);
4216 yylval.ival = PL_curcop->cop_line;
4220 yylval.ival = PL_curcop->cop_line;
4224 LOP(OP_UNLINK,XTERM);
4230 LOP(OP_UNPACK,XTERM);
4233 LOP(OP_UTIME,XTERM);
4236 if (ckWARN(WARN_OCTAL)) {
4237 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4238 if (*d != '0' && isDIGIT(*d))
4239 yywarn("umask: argument is missing initial 0");
4244 LOP(OP_UNSHIFT,XTERM);
4247 if (PL_expect != XSTATE)
4248 yyerror("\"use\" not allowed in expression");
4251 s = force_version(s);
4252 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4253 PL_nextval[PL_nexttoke].opval = Nullop;
4258 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4259 s = force_version(s);
4272 yylval.ival = PL_curcop->cop_line;
4276 PL_hints |= HINT_BLOCK_SCOPE;
4283 LOP(OP_WAITPID,XTERM);
4291 static char ctl_l[2];
4293 if (ctl_l[0] == '\0')
4294 ctl_l[0] = toCTRL('L');
4295 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4298 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4303 if (PL_expect == XOPERATOR)
4309 yylval.ival = OP_XOR;
4314 TERM(sublex_start());
4320 keyword(register char *d, I32 len)
4325 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4326 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4327 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4328 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4329 if (strEQ(d,"__END__")) return KEY___END__;
4333 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4338 if (strEQ(d,"and")) return -KEY_and;
4339 if (strEQ(d,"abs")) return -KEY_abs;
4342 if (strEQ(d,"alarm")) return -KEY_alarm;
4343 if (strEQ(d,"atan2")) return -KEY_atan2;
4346 if (strEQ(d,"accept")) return -KEY_accept;
4351 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4354 if (strEQ(d,"bless")) return -KEY_bless;
4355 if (strEQ(d,"bind")) return -KEY_bind;
4356 if (strEQ(d,"binmode")) return -KEY_binmode;
4359 if (strEQ(d,"CORE")) return -KEY_CORE;
4364 if (strEQ(d,"cmp")) return -KEY_cmp;
4365 if (strEQ(d,"chr")) return -KEY_chr;
4366 if (strEQ(d,"cos")) return -KEY_cos;
4369 if (strEQ(d,"chop")) return KEY_chop;
4372 if (strEQ(d,"close")) return -KEY_close;
4373 if (strEQ(d,"chdir")) return -KEY_chdir;
4374 if (strEQ(d,"chomp")) return KEY_chomp;
4375 if (strEQ(d,"chmod")) return -KEY_chmod;
4376 if (strEQ(d,"chown")) return -KEY_chown;
4377 if (strEQ(d,"crypt")) return -KEY_crypt;
4380 if (strEQ(d,"chroot")) return -KEY_chroot;
4381 if (strEQ(d,"caller")) return -KEY_caller;
4384 if (strEQ(d,"connect")) return -KEY_connect;
4387 if (strEQ(d,"closedir")) return -KEY_closedir;
4388 if (strEQ(d,"continue")) return -KEY_continue;
4393 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4398 if (strEQ(d,"do")) return KEY_do;
4401 if (strEQ(d,"die")) return -KEY_die;
4404 if (strEQ(d,"dump")) return -KEY_dump;
4407 if (strEQ(d,"delete")) return KEY_delete;
4410 if (strEQ(d,"defined")) return KEY_defined;
4411 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4414 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4419 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4420 if (strEQ(d,"END")) return KEY_END;
4425 if (strEQ(d,"eq")) return -KEY_eq;
4428 if (strEQ(d,"eof")) return -KEY_eof;
4429 if (strEQ(d,"exp")) return -KEY_exp;
4432 if (strEQ(d,"else")) return KEY_else;
4433 if (strEQ(d,"exit")) return -KEY_exit;
4434 if (strEQ(d,"eval")) return KEY_eval;
4435 if (strEQ(d,"exec")) return -KEY_exec;
4436 if (strEQ(d,"each")) return KEY_each;
4439 if (strEQ(d,"elsif")) return KEY_elsif;
4442 if (strEQ(d,"exists")) return KEY_exists;
4443 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4446 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4447 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4450 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4453 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4454 if (strEQ(d,"endservent")) return -KEY_endservent;
4457 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4464 if (strEQ(d,"for")) return KEY_for;
4467 if (strEQ(d,"fork")) return -KEY_fork;
4470 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4471 if (strEQ(d,"flock")) return -KEY_flock;
4474 if (strEQ(d,"format")) return KEY_format;
4475 if (strEQ(d,"fileno")) return -KEY_fileno;
4478 if (strEQ(d,"foreach")) return KEY_foreach;
4481 if (strEQ(d,"formline")) return -KEY_formline;
4487 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4488 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4492 if (strnEQ(d,"get",3)) {
4497 if (strEQ(d,"ppid")) return -KEY_getppid;
4498 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4501 if (strEQ(d,"pwent")) return -KEY_getpwent;
4502 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4503 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4506 if (strEQ(d,"peername")) return -KEY_getpeername;
4507 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4508 if (strEQ(d,"priority")) return -KEY_getpriority;
4511 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4514 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4518 else if (*d == 'h') {
4519 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4520 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4521 if (strEQ(d,"hostent")) return -KEY_gethostent;
4523 else if (*d == 'n') {
4524 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4525 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4526 if (strEQ(d,"netent")) return -KEY_getnetent;
4528 else if (*d == 's') {
4529 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4530 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4531 if (strEQ(d,"servent")) return -KEY_getservent;
4532 if (strEQ(d,"sockname")) return -KEY_getsockname;
4533 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4535 else if (*d == 'g') {
4536 if (strEQ(d,"grent")) return -KEY_getgrent;
4537 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4538 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4540 else if (*d == 'l') {
4541 if (strEQ(d,"login")) return -KEY_getlogin;
4543 else if (strEQ(d,"c")) return -KEY_getc;
4548 if (strEQ(d,"gt")) return -KEY_gt;
4549 if (strEQ(d,"ge")) return -KEY_ge;
4552 if (strEQ(d,"grep")) return KEY_grep;
4553 if (strEQ(d,"goto")) return KEY_goto;
4554 if (strEQ(d,"glob")) return KEY_glob;
4557 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4562 if (strEQ(d,"hex")) return -KEY_hex;
4565 if (strEQ(d,"INIT")) return KEY_INIT;
4570 if (strEQ(d,"if")) return KEY_if;
4573 if (strEQ(d,"int")) return -KEY_int;
4576 if (strEQ(d,"index")) return -KEY_index;
4577 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4582 if (strEQ(d,"join")) return -KEY_join;
4586 if (strEQ(d,"keys")) return KEY_keys;
4587 if (strEQ(d,"kill")) return -KEY_kill;
4592 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4593 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4599 if (strEQ(d,"lt")) return -KEY_lt;
4600 if (strEQ(d,"le")) return -KEY_le;
4601 if (strEQ(d,"lc")) return -KEY_lc;
4604 if (strEQ(d,"log")) return -KEY_log;
4607 if (strEQ(d,"last")) return KEY_last;
4608 if (strEQ(d,"link")) return -KEY_link;
4609 if (strEQ(d,"lock")) return -KEY_lock;
4612 if (strEQ(d,"local")) return KEY_local;
4613 if (strEQ(d,"lstat")) return -KEY_lstat;
4616 if (strEQ(d,"length")) return -KEY_length;
4617 if (strEQ(d,"listen")) return -KEY_listen;
4620 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4623 if (strEQ(d,"localtime")) return -KEY_localtime;
4629 case 1: return KEY_m;
4631 if (strEQ(d,"my")) return KEY_my;
4634 if (strEQ(d,"map")) return KEY_map;
4637 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4640 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4641 if (strEQ(d,"msgget")) return -KEY_msgget;
4642 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4643 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4648 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4651 if (strEQ(d,"next")) return KEY_next;
4652 if (strEQ(d,"ne")) return -KEY_ne;
4653 if (strEQ(d,"not")) return -KEY_not;
4654 if (strEQ(d,"no")) return KEY_no;
4659 if (strEQ(d,"or")) return -KEY_or;
4662 if (strEQ(d,"ord")) return -KEY_ord;
4663 if (strEQ(d,"oct")) return -KEY_oct;
4664 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4668 if (strEQ(d,"open")) return -KEY_open;
4671 if (strEQ(d,"opendir")) return -KEY_opendir;
4678 if (strEQ(d,"pop")) return KEY_pop;
4679 if (strEQ(d,"pos")) return KEY_pos;
4682 if (strEQ(d,"push")) return KEY_push;
4683 if (strEQ(d,"pack")) return -KEY_pack;
4684 if (strEQ(d,"pipe")) return -KEY_pipe;
4687 if (strEQ(d,"print")) return KEY_print;
4690 if (strEQ(d,"printf")) return KEY_printf;
4693 if (strEQ(d,"package")) return KEY_package;
4696 if (strEQ(d,"prototype")) return KEY_prototype;
4701 if (strEQ(d,"q")) return KEY_q;
4702 if (strEQ(d,"qr")) return KEY_qr;
4703 if (strEQ(d,"qq")) return KEY_qq;
4704 if (strEQ(d,"qw")) return KEY_qw;
4705 if (strEQ(d,"qx")) return KEY_qx;
4707 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4712 if (strEQ(d,"ref")) return -KEY_ref;
4715 if (strEQ(d,"read")) return -KEY_read;
4716 if (strEQ(d,"rand")) return -KEY_rand;
4717 if (strEQ(d,"recv")) return -KEY_recv;
4718 if (strEQ(d,"redo")) return KEY_redo;
4721 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4722 if (strEQ(d,"reset")) return -KEY_reset;
4725 if (strEQ(d,"return")) return KEY_return;
4726 if (strEQ(d,"rename")) return -KEY_rename;
4727 if (strEQ(d,"rindex")) return -KEY_rindex;
4730 if (strEQ(d,"require")) return -KEY_require;
4731 if (strEQ(d,"reverse")) return -KEY_reverse;
4732 if (strEQ(d,"readdir")) return -KEY_readdir;
4735 if (strEQ(d,"readlink")) return -KEY_readlink;
4736 if (strEQ(d,"readline")) return -KEY_readline;
4737 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4740 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4746 case 0: return KEY_s;
4748 if (strEQ(d,"scalar")) return KEY_scalar;
4753 if (strEQ(d,"seek")) return -KEY_seek;
4754 if (strEQ(d,"send")) return -KEY_send;
4757 if (strEQ(d,"semop")) return -KEY_semop;
4760 if (strEQ(d,"select")) return -KEY_select;
4761 if (strEQ(d,"semctl")) return -KEY_semctl;
4762 if (strEQ(d,"semget")) return -KEY_semget;
4765 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4766 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4769 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4770 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4773 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4776 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4777 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4778 if (strEQ(d,"setservent")) return -KEY_setservent;
4781 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4782 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4789 if (strEQ(d,"shift")) return KEY_shift;
4792 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4793 if (strEQ(d,"shmget")) return -KEY_shmget;
4796 if (strEQ(d,"shmread")) return -KEY_shmread;
4799 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4800 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4805 if (strEQ(d,"sin")) return -KEY_sin;
4808 if (strEQ(d,"sleep")) return -KEY_sleep;
4811 if (strEQ(d,"sort")) return KEY_sort;
4812 if (strEQ(d,"socket")) return -KEY_socket;
4813 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4816 if (strEQ(d,"split")) return KEY_split;
4817 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4818 if (strEQ(d,"splice")) return KEY_splice;
4821 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4824 if (strEQ(d,"srand")) return -KEY_srand;
4827 if (strEQ(d,"stat")) return -KEY_stat;
4828 if (strEQ(d,"study")) return KEY_study;
4831 if (strEQ(d,"substr")) return -KEY_substr;
4832 if (strEQ(d,"sub")) return KEY_sub;
4837 if (strEQ(d,"system")) return -KEY_system;
4840 if (strEQ(d,"symlink")) return -KEY_symlink;
4841 if (strEQ(d,"syscall")) return -KEY_syscall;
4842 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4843 if (strEQ(d,"sysread")) return -KEY_sysread;
4844 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4847 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4856 if (strEQ(d,"tr")) return KEY_tr;
4859 if (strEQ(d,"tie")) return KEY_tie;
4862 if (strEQ(d,"tell")) return -KEY_tell;
4863 if (strEQ(d,"tied")) return KEY_tied;
4864 if (strEQ(d,"time")) return -KEY_time;
4867 if (strEQ(d,"times")) return -KEY_times;
4870 if (strEQ(d,"telldir")) return -KEY_telldir;
4873 if (strEQ(d,"truncate")) return -KEY_truncate;
4880 if (strEQ(d,"uc")) return -KEY_uc;
4883 if (strEQ(d,"use")) return KEY_use;
4886 if (strEQ(d,"undef")) return KEY_undef;
4887 if (strEQ(d,"until")) return KEY_until;
4888 if (strEQ(d,"untie")) return KEY_untie;
4889 if (strEQ(d,"utime")) return -KEY_utime;
4890 if (strEQ(d,"umask")) return -KEY_umask;
4893 if (strEQ(d,"unless")) return KEY_unless;
4894 if (strEQ(d,"unpack")) return -KEY_unpack;
4895 if (strEQ(d,"unlink")) return -KEY_unlink;
4898 if (strEQ(d,"unshift")) return KEY_unshift;
4899 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4904 if (strEQ(d,"values")) return -KEY_values;
4905 if (strEQ(d,"vec")) return -KEY_vec;
4910 if (strEQ(d,"warn")) return -KEY_warn;
4911 if (strEQ(d,"wait")) return -KEY_wait;
4914 if (strEQ(d,"while")) return KEY_while;
4915 if (strEQ(d,"write")) return -KEY_write;
4918 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4921 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4926 if (len == 1) return -KEY_x;
4927 if (strEQ(d,"xor")) return -KEY_xor;
4930 if (len == 1) return KEY_y;
4939 checkcomma(register char *s, char *name, char *what)
4943 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4944 dTHR; /* only for ckWARN */
4945 if (ckWARN(WARN_SYNTAX)) {
4947 for (w = s+2; *w && level; w++) {
4954 for (; *w && isSPACE(*w); w++) ;
4955 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4956 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4959 while (s < PL_bufend && isSPACE(*s))
4963 while (s < PL_bufend && isSPACE(*s))
4965 if (isIDFIRST_lazy(s)) {
4967 while (isALNUM_lazy(s))
4969 while (s < PL_bufend && isSPACE(*s))
4974 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4978 croak("No comma allowed after %s", what);
4984 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4987 HV *table = GvHV(PL_hintgv); /* ^H */
4990 bool oldcatch = CATCH_GET;
4995 yyerror("%^H is not defined");
4998 cvp = hv_fetch(table, key, strlen(key), FALSE);
4999 if (!cvp || !SvOK(*cvp)) {
5001 sprintf(buf,"$^H{%s} is not defined", key);
5005 sv_2mortal(sv); /* Parent created it permanently */
5008 pv = sv_2mortal(newSVpv(s, len));
5010 typesv = sv_2mortal(newSVpv(type, 0));
5012 typesv = &PL_sv_undef;
5014 Zero(&myop, 1, BINOP);
5015 myop.op_last = (OP *) &myop;
5016 myop.op_next = Nullop;
5017 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
5019 PUSHSTACKi(PERLSI_OVERLOAD);
5022 PL_op = (OP *) &myop;
5023 if (PERLDB_SUB && PL_curstash != PL_debstash)
5024 PL_op->op_private |= OPpENTERSUB_DB;
5035 if (PL_op = pp_entersub(ARGS))
5042 CATCH_SET(oldcatch);
5047 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5050 return SvREFCNT_inc(res);
5054 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5056 register char *d = dest;
5057 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5060 croak(ident_too_long);
5061 if (isALNUM(*s)) /* UTF handled below */
5063 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5068 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5072 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5073 char *t = s + UTF8SKIP(s);
5074 while (*t & 0x80 && is_utf8_mark((U8*)t))
5076 if (d + (t - s) > e)
5077 croak(ident_too_long);
5078 Copy(s, d, t - s, char);
5091 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5098 if (PL_lex_brackets == 0)
5099 PL_lex_fakebrack = 0;
5103 e = d + destlen - 3; /* two-character token, ending NUL */
5105 while (isDIGIT(*s)) {
5107 croak(ident_too_long);
5114 croak(ident_too_long);
5115 if (isALNUM(*s)) /* UTF handled below */
5117 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5122 else if (*s == ':' && s[1] == ':') {
5126 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5127 char *t = s + UTF8SKIP(s);
5128 while (*t & 0x80 && is_utf8_mark((U8*)t))
5130 if (d + (t - s) > e)
5131 croak(ident_too_long);
5132 Copy(s, d, t - s, char);
5143 if (PL_lex_state != LEX_NORMAL)
5144 PL_lex_state = LEX_INTERPENDMAYBE;
5147 if (*s == '$' && s[1] &&
5148 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5161 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5166 if (isSPACE(s[-1])) {
5169 if (ch != ' ' && ch != '\t') {
5175 if (isIDFIRST_lazy(d)) {
5179 while (e < send && isALNUM_lazy(e) || *e == ':') {
5181 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5184 Copy(s, d, e - s, char);
5189 while (isALNUM(*s) || *s == ':')
5193 while (s < send && (*s == ' ' || *s == '\t')) s++;
5194 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5195 dTHR; /* only for ckWARN */
5196 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5197 char *brack = *s == '[' ? "[...]" : "{...}";
5198 warner(WARN_AMBIGUOUS,
5199 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5200 funny, dest, brack, funny, dest, brack);
5202 PL_lex_fakebrack = PL_lex_brackets+1;
5204 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5210 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5211 PL_lex_state = LEX_INTERPEND;
5214 if (PL_lex_state == LEX_NORMAL) {
5215 dTHR; /* only for ckWARN */
5216 if (ckWARN(WARN_AMBIGUOUS) &&
5217 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5219 warner(WARN_AMBIGUOUS,
5220 "Ambiguous use of %c{%s} resolved to %c%s",
5221 funny, dest, funny, dest);
5226 s = bracket; /* let the parser handle it */
5230 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5231 PL_lex_state = LEX_INTERPEND;
5235 void pmflag(U16 *pmfl, int ch)
5240 *pmfl |= PMf_GLOBAL;
5242 *pmfl |= PMf_CONTINUE;
5246 *pmfl |= PMf_MULTILINE;
5248 *pmfl |= PMf_SINGLELINE;
5250 *pmfl |= PMf_EXTENDED;
5254 scan_pat(char *start, I32 type)
5259 s = scan_str(start);
5262 SvREFCNT_dec(PL_lex_stuff);
5263 PL_lex_stuff = Nullsv;
5264 croak("Search pattern not terminated");
5267 pm = (PMOP*)newPMOP(type, 0);
5268 if (PL_multi_open == '?')
5269 pm->op_pmflags |= PMf_ONCE;
5271 while (*s && strchr("iomsx", *s))
5272 pmflag(&pm->op_pmflags,*s++);
5275 while (*s && strchr("iogcmsx", *s))
5276 pmflag(&pm->op_pmflags,*s++);
5278 pm->op_pmpermflags = pm->op_pmflags;
5280 PL_lex_op = (OP*)pm;
5281 yylval.ival = OP_MATCH;
5286 scan_subst(char *start)
5293 yylval.ival = OP_NULL;
5295 s = scan_str(start);
5299 SvREFCNT_dec(PL_lex_stuff);
5300 PL_lex_stuff = Nullsv;
5301 croak("Substitution pattern not terminated");
5304 if (s[-1] == PL_multi_open)
5307 first_start = PL_multi_start;
5311 SvREFCNT_dec(PL_lex_stuff);
5312 PL_lex_stuff = Nullsv;
5314 SvREFCNT_dec(PL_lex_repl);
5315 PL_lex_repl = Nullsv;
5316 croak("Substitution replacement not terminated");
5318 PL_multi_start = first_start; /* so whole substitution is taken together */
5320 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5326 else if (strchr("iogcmsx", *s))
5327 pmflag(&pm->op_pmflags,*s++);
5334 pm->op_pmflags |= PMf_EVAL;
5335 repl = newSVpv("",0);
5337 sv_catpv(repl, es ? "eval " : "do ");
5338 sv_catpvn(repl, "{ ", 2);
5339 sv_catsv(repl, PL_lex_repl);
5340 sv_catpvn(repl, " };", 2);
5341 SvCOMPILED_on(repl);
5342 SvREFCNT_dec(PL_lex_repl);
5346 pm->op_pmpermflags = pm->op_pmflags;
5347 PL_lex_op = (OP*)pm;
5348 yylval.ival = OP_SUBST;
5353 scan_trans(char *start)
5364 yylval.ival = OP_NULL;
5366 s = scan_str(start);
5369 SvREFCNT_dec(PL_lex_stuff);
5370 PL_lex_stuff = Nullsv;
5371 croak("Transliteration pattern not terminated");
5373 if (s[-1] == PL_multi_open)
5379 SvREFCNT_dec(PL_lex_stuff);
5380 PL_lex_stuff = Nullsv;
5382 SvREFCNT_dec(PL_lex_repl);
5383 PL_lex_repl = Nullsv;
5384 croak("Transliteration replacement not terminated");
5388 o = newSVOP(OP_TRANS, 0, 0);
5389 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5392 New(803,tbl,256,short);
5393 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5397 complement = del = squash = 0;
5398 while (strchr("cdsCU", *s)) {
5400 complement = OPpTRANS_COMPLEMENT;
5402 del = OPpTRANS_DELETE;
5404 squash = OPpTRANS_SQUASH;
5409 utf8 &= ~OPpTRANS_FROM_UTF;
5411 utf8 |= OPpTRANS_FROM_UTF;
5415 utf8 &= ~OPpTRANS_TO_UTF;
5417 utf8 |= OPpTRANS_TO_UTF;
5420 croak("Too many /C and /U options");
5425 o->op_private = del|squash|complement|utf8;
5428 yylval.ival = OP_TRANS;
5433 scan_heredoc(register char *s)
5437 I32 op_type = OP_SCALAR;
5444 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5448 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5451 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5452 if (*peek && strchr("`'\"",*peek)) {
5455 s = delimcpy(d, e, s, PL_bufend, term, &len);
5465 if (!isALNUM_lazy(s))
5466 deprecate("bare << to mean <<\"\"");
5467 for (; isALNUM_lazy(s); s++) {
5472 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5473 croak("Delimiter for here document is too long");
5476 len = d - PL_tokenbuf;
5477 #ifndef PERL_STRICT_CR
5478 d = strchr(s, '\r');
5482 while (s < PL_bufend) {
5488 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5497 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5502 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5503 herewas = newSVpv(s,PL_bufend-s);
5505 s--, herewas = newSVpv(s,d-s);
5506 s += SvCUR(herewas);
5508 tmpstr = NEWSV(87,79);
5509 sv_upgrade(tmpstr, SVt_PVIV);
5514 else if (term == '`') {
5515 op_type = OP_BACKTICK;
5516 SvIVX(tmpstr) = '\\';
5520 PL_multi_start = PL_curcop->cop_line;
5521 PL_multi_open = PL_multi_close = '<';
5522 term = *PL_tokenbuf;
5525 while (s < PL_bufend &&
5526 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5528 PL_curcop->cop_line++;
5530 if (s >= PL_bufend) {
5531 PL_curcop->cop_line = PL_multi_start;
5532 missingterm(PL_tokenbuf);
5534 sv_setpvn(tmpstr,d+1,s-d);
5536 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5538 sv_catpvn(herewas,s,PL_bufend-s);
5539 sv_setsv(PL_linestr,herewas);
5540 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5541 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5544 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5545 while (s >= PL_bufend) { /* multiple line string? */
5547 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5548 PL_curcop->cop_line = PL_multi_start;
5549 missingterm(PL_tokenbuf);
5551 PL_curcop->cop_line++;
5552 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5553 #ifndef PERL_STRICT_CR
5554 if (PL_bufend - PL_linestart >= 2) {
5555 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5556 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5558 PL_bufend[-2] = '\n';
5560 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5562 else if (PL_bufend[-1] == '\r')
5563 PL_bufend[-1] = '\n';
5565 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5566 PL_bufend[-1] = '\n';
5568 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5569 SV *sv = NEWSV(88,0);
5571 sv_upgrade(sv, SVt_PVMG);
5572 sv_setsv(sv,PL_linestr);
5573 av_store(GvAV(PL_curcop->cop_filegv),
5574 (I32)PL_curcop->cop_line,sv);
5576 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5579 sv_catsv(PL_linestr,herewas);
5580 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5584 sv_catsv(tmpstr,PL_linestr);
5587 PL_multi_end = PL_curcop->cop_line;
5589 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5590 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5591 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5593 SvREFCNT_dec(herewas);
5594 PL_lex_stuff = tmpstr;
5595 yylval.ival = op_type;
5600 takes: current position in input buffer
5601 returns: new position in input buffer
5602 side-effects: yylval and lex_op are set.
5607 <FH> read from filehandle
5608 <pkg::FH> read from package qualified filehandle
5609 <pkg'FH> read from package qualified filehandle
5610 <$fh> read from filehandle in $fh
5616 scan_inputsymbol(char *start)
5618 register char *s = start; /* current position in buffer */
5623 d = PL_tokenbuf; /* start of temp holding space */
5624 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5625 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5627 /* die if we didn't have space for the contents of the <>,
5631 if (len >= sizeof PL_tokenbuf)
5632 croak("Excessively long <> operator");
5634 croak("Unterminated <> operator");
5639 Remember, only scalar variables are interpreted as filehandles by
5640 this code. Anything more complex (e.g., <$fh{$num}>) will be
5641 treated as a glob() call.
5642 This code makes use of the fact that except for the $ at the front,
5643 a scalar variable and a filehandle look the same.
5645 if (*d == '$' && d[1]) d++;
5647 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5648 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5651 /* If we've tried to read what we allow filehandles to look like, and
5652 there's still text left, then it must be a glob() and not a getline.
5653 Use scan_str to pull out the stuff between the <> and treat it
5654 as nothing more than a string.
5657 if (d - PL_tokenbuf != len) {
5658 yylval.ival = OP_GLOB;
5660 s = scan_str(start);
5662 croak("Glob not terminated");
5666 /* we're in a filehandle read situation */
5669 /* turn <> into <ARGV> */
5671 (void)strcpy(d,"ARGV");
5673 /* if <$fh>, create the ops to turn the variable into a
5679 /* try to find it in the pad for this block, otherwise find
5680 add symbol table ops
5682 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5683 OP *o = newOP(OP_PADSV, 0);
5685 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5688 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5689 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5690 newUNOP(OP_RV2SV, 0,
5691 newGVOP(OP_GV, 0, gv)));
5693 PL_lex_op->op_flags |= OPf_SPECIAL;
5694 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5695 yylval.ival = OP_NULL;
5698 /* If it's none of the above, it must be a literal filehandle
5699 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5701 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5702 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5703 yylval.ival = OP_NULL;
5712 takes: start position in buffer
5713 returns: position to continue reading from buffer
5714 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5715 updates the read buffer.
5717 This subroutine pulls a string out of the input. It is called for:
5718 q single quotes q(literal text)
5719 ' single quotes 'literal text'
5720 qq double quotes qq(interpolate $here please)
5721 " double quotes "interpolate $here please"
5722 qx backticks qx(/bin/ls -l)
5723 ` backticks `/bin/ls -l`
5724 qw quote words @EXPORT_OK = qw( func() $spam )
5725 m// regexp match m/this/
5726 s/// regexp substitute s/this/that/
5727 tr/// string transliterate tr/this/that/
5728 y/// string transliterate y/this/that/
5729 ($*@) sub prototypes sub foo ($)
5730 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5732 In most of these cases (all but <>, patterns and transliterate)
5733 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5734 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5735 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5738 It skips whitespace before the string starts, and treats the first
5739 character as the delimiter. If the delimiter is one of ([{< then
5740 the corresponding "close" character )]}> is used as the closing
5741 delimiter. It allows quoting of delimiters, and if the string has
5742 balanced delimiters ([{<>}]) it allows nesting.
5744 The lexer always reads these strings into lex_stuff, except in the
5745 case of the operators which take *two* arguments (s/// and tr///)
5746 when it checks to see if lex_stuff is full (presumably with the 1st
5747 arg to s or tr) and if so puts the string into lex_repl.
5752 scan_str(char *start)
5755 SV *sv; /* scalar value: string */
5756 char *tmps; /* temp string, used for delimiter matching */
5757 register char *s = start; /* current position in the buffer */
5758 register char term; /* terminating character */
5759 register char *to; /* current position in the sv's data */
5760 I32 brackets = 1; /* bracket nesting level */
5762 /* skip space before the delimiter */
5766 /* mark where we are, in case we need to report errors */
5769 /* after skipping whitespace, the next character is the terminator */
5771 /* mark where we are */
5772 PL_multi_start = PL_curcop->cop_line;
5773 PL_multi_open = term;
5775 /* find corresponding closing delimiter */
5776 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5778 PL_multi_close = term;
5780 /* create a new SV to hold the contents. 87 is leak category, I'm
5781 assuming. 79 is the SV's initial length. What a random number. */
5783 sv_upgrade(sv, SVt_PVIV);
5785 (void)SvPOK_only(sv); /* validate pointer */
5787 /* move past delimiter and try to read a complete string */
5790 /* extend sv if need be */
5791 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5792 /* set 'to' to the next character in the sv's string */
5793 to = SvPVX(sv)+SvCUR(sv);
5795 /* if open delimiter is the close delimiter read unbridle */
5796 if (PL_multi_open == PL_multi_close) {
5797 for (; s < PL_bufend; s++,to++) {
5798 /* embedded newlines increment the current line number */
5799 if (*s == '\n' && !PL_rsfp)
5800 PL_curcop->cop_line++;
5801 /* handle quoted delimiters */
5802 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5805 /* any other quotes are simply copied straight through */
5809 /* terminate when run out of buffer (the for() condition), or
5810 have found the terminator */
5811 else if (*s == term)
5817 /* if the terminator isn't the same as the start character (e.g.,
5818 matched brackets), we have to allow more in the quoting, and
5819 be prepared for nested brackets.
5822 /* read until we run out of string, or we find the terminator */
5823 for (; s < PL_bufend; s++,to++) {
5824 /* embedded newlines increment the line count */
5825 if (*s == '\n' && !PL_rsfp)
5826 PL_curcop->cop_line++;
5827 /* backslashes can escape the open or closing characters */
5828 if (*s == '\\' && s+1 < PL_bufend) {
5829 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5834 /* allow nested opens and closes */
5835 else if (*s == PL_multi_close && --brackets <= 0)
5837 else if (*s == PL_multi_open)
5842 /* terminate the copied string and update the sv's end-of-string */
5844 SvCUR_set(sv, to - SvPVX(sv));
5847 * this next chunk reads more into the buffer if we're not done yet
5850 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5852 #ifndef PERL_STRICT_CR
5853 if (to - SvPVX(sv) >= 2) {
5854 if ((to[-2] == '\r' && to[-1] == '\n') ||
5855 (to[-2] == '\n' && to[-1] == '\r'))
5859 SvCUR_set(sv, to - SvPVX(sv));
5861 else if (to[-1] == '\r')
5864 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5868 /* if we're out of file, or a read fails, bail and reset the current
5869 line marker so we can report where the unterminated string began
5872 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5874 PL_curcop->cop_line = PL_multi_start;
5877 /* we read a line, so increment our line counter */
5878 PL_curcop->cop_line++;
5880 /* update debugger info */
5881 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5882 SV *sv = NEWSV(88,0);
5884 sv_upgrade(sv, SVt_PVMG);
5885 sv_setsv(sv,PL_linestr);
5886 av_store(GvAV(PL_curcop->cop_filegv),
5887 (I32)PL_curcop->cop_line, sv);
5890 /* having changed the buffer, we must update PL_bufend */
5891 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5894 /* at this point, we have successfully read the delimited string */
5896 PL_multi_end = PL_curcop->cop_line;
5899 /* if we allocated too much space, give some back */
5900 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5901 SvLEN_set(sv, SvCUR(sv) + 1);
5902 Renew(SvPVX(sv), SvLEN(sv), char);
5905 /* decide whether this is the first or second quoted string we've read
5918 takes: pointer to position in buffer
5919 returns: pointer to new position in buffer
5920 side-effects: builds ops for the constant in yylval.op
5922 Read a number in any of the formats that Perl accepts:
5924 0(x[0-7A-F]+)|([0-7]+)|(b[01])
5925 [\d_]+(\.[\d_]*)?[Ee](\d+)
5927 Underbars (_) are allowed in decimal numbers. If -w is on,
5928 underbars before a decimal point must be at three digit intervals.
5930 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5933 If it reads a number without a decimal point or an exponent, it will
5934 try converting the number to an integer and see if it can do so
5935 without loss of precision.
5939 scan_num(char *start)
5941 register char *s = start; /* current position in buffer */
5942 register char *d; /* destination in temp buffer */
5943 register char *e; /* end of temp buffer */
5944 I32 tryiv; /* used to see if it can be an int */
5945 double value; /* number read, as a double */
5946 SV *sv; /* place to put the converted number */
5947 I32 floatit; /* boolean: int or float? */
5948 char *lastub = 0; /* position of last underbar */
5949 static char number_too_long[] = "Number too long";
5951 /* We use the first character to decide what type of number this is */
5955 croak("panic: scan_num");
5957 /* if it starts with a 0, it could be an octal number, a decimal in
5958 0.13 disguise, or a hexadecimal number, or a binary number.
5963 u holds the "number so far"
5964 shift the power of 2 of the base
5965 (hex == 4, octal == 3, binary == 1)
5966 overflowed was the number more than we can hold?
5968 Shift is used when we add a digit. It also serves as an "are
5969 we in octal/hex/binary?" indicator to disallow hex characters
5974 bool overflowed = FALSE;
5980 } else if (s[1] == 'b') {
5984 /* check for a decimal in disguise */
5985 else if (s[1] == '.')
5987 /* so it must be octal */
5992 /* read the rest of the number */
5994 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5998 /* if we don't mention it, we're done */
6007 /* 8 and 9 are not octal */
6010 yyerror("Illegal octal digit");
6013 yyerror("Illegal binary digit");
6017 case '2': case '3': case '4':
6018 case '5': case '6': case '7':
6020 yyerror("Illegal binary digit");
6024 b = *s++ & 15; /* ASCII digit -> value of digit */
6028 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6029 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6030 /* make sure they said 0x */
6035 /* Prepare to put the digit we have onto the end
6036 of the number so far. We check for overflows.
6040 n = u << shift; /* make room for the digit */
6041 if (!overflowed && (n >> shift) != u
6042 && !(PL_hints & HINT_NEW_BINARY)) {
6043 warn("Integer overflow in %s number",
6044 (shift == 4) ? "hex"
6045 : ((shift == 3) ? "octal" : "binary"));
6048 u = n | b; /* add the digit to the end */
6053 /* if we get here, we had success: make a scalar value from
6059 if ( PL_hints & HINT_NEW_BINARY)
6060 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6065 handle decimal numbers.
6066 we're also sent here when we read a 0 as the first digit
6068 case '1': case '2': case '3': case '4': case '5':
6069 case '6': case '7': case '8': case '9': case '.':
6072 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6075 /* read next group of digits and _ and copy into d */
6076 while (isDIGIT(*s) || *s == '_') {
6077 /* skip underscores, checking for misplaced ones
6081 dTHR; /* only for ckWARN */
6082 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6083 warner(WARN_SYNTAX, "Misplaced _ in number");
6087 /* check for end of fixed-length buffer */
6089 croak(number_too_long);
6090 /* if we're ok, copy the character */
6095 /* final misplaced underbar check */
6096 if (lastub && s - lastub != 3) {
6098 if (ckWARN(WARN_SYNTAX))
6099 warner(WARN_SYNTAX, "Misplaced _ in number");
6102 /* read a decimal portion if there is one. avoid
6103 3..5 being interpreted as the number 3. followed
6106 if (*s == '.' && s[1] != '.') {
6110 /* copy, ignoring underbars, until we run out of
6111 digits. Note: no misplaced underbar checks!
6113 for (; isDIGIT(*s) || *s == '_'; s++) {
6114 /* fixed length buffer check */
6116 croak(number_too_long);
6122 /* read exponent part, if present */
6123 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6127 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6128 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6130 /* allow positive or negative exponent */
6131 if (*s == '+' || *s == '-')
6134 /* read digits of exponent (no underbars :-) */
6135 while (isDIGIT(*s)) {
6137 croak(number_too_long);
6142 /* terminate the string */
6145 /* make an sv from the string */
6147 /* reset numeric locale in case we were earlier left in Swaziland */
6148 SET_NUMERIC_STANDARD();
6149 value = atof(PL_tokenbuf);
6152 See if we can make do with an integer value without loss of
6153 precision. We use I_V to cast to an int, because some
6154 compilers have issues. Then we try casting it back and see
6155 if it was the same. We only do this if we know we
6156 specifically read an integer.
6158 Note: if floatit is true, then we don't need to do the
6162 if (!floatit && (double)tryiv == value)
6163 sv_setiv(sv, tryiv);
6165 sv_setnv(sv, value);
6166 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6167 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6168 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6172 /* make the op for the constant and return */
6174 yylval.opval = newSVOP(OP_CONST, 0, sv);
6180 scan_formline(register char *s)
6185 SV *stuff = newSVpv("",0);
6186 bool needargs = FALSE;
6189 if (*s == '.' || *s == '}') {
6191 #ifdef PERL_STRICT_CR
6192 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6194 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6196 if (*t == '\n' || t == PL_bufend)
6199 if (PL_in_eval && !PL_rsfp) {
6200 eol = strchr(s,'\n');
6205 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6207 for (t = s; t < eol; t++) {
6208 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6210 goto enough; /* ~~ must be first line in formline */
6212 if (*t == '@' || *t == '^')
6215 sv_catpvn(stuff, s, eol-s);
6219 s = filter_gets(PL_linestr, PL_rsfp, 0);
6220 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6221 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6224 yyerror("Format not terminated");
6234 PL_lex_state = LEX_NORMAL;
6235 PL_nextval[PL_nexttoke].ival = 0;
6239 PL_lex_state = LEX_FORMLINE;
6240 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6242 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6246 SvREFCNT_dec(stuff);
6247 PL_lex_formbrack = 0;
6258 PL_cshlen = strlen(PL_cshname);
6263 start_subparse(I32 is_format, U32 flags)
6266 I32 oldsavestack_ix = PL_savestack_ix;
6267 CV* outsidecv = PL_compcv;
6271 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6273 save_I32(&PL_subline);
6274 save_item(PL_subname);
6276 SAVESPTR(PL_curpad);
6277 SAVESPTR(PL_comppad);
6278 SAVESPTR(PL_comppad_name);
6279 SAVESPTR(PL_compcv);
6280 SAVEI32(PL_comppad_name_fill);
6281 SAVEI32(PL_min_intro_pending);
6282 SAVEI32(PL_max_intro_pending);
6283 SAVEI32(PL_pad_reset_pending);
6285 PL_compcv = (CV*)NEWSV(1104,0);
6286 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6287 CvFLAGS(PL_compcv) |= flags;
6289 PL_comppad = newAV();
6290 av_push(PL_comppad, Nullsv);
6291 PL_curpad = AvARRAY(PL_comppad);
6292 PL_comppad_name = newAV();
6293 PL_comppad_name_fill = 0;
6294 PL_min_intro_pending = 0;
6296 PL_subline = PL_curcop->cop_line;
6298 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6299 PL_curpad[0] = (SV*)newAV();
6300 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6301 #endif /* USE_THREADS */
6303 comppadlist = newAV();
6304 AvREAL_off(comppadlist);
6305 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6306 av_store(comppadlist, 1, (SV*)PL_comppad);
6308 CvPADLIST(PL_compcv) = comppadlist;
6309 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6311 CvOWNER(PL_compcv) = 0;
6312 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6313 MUTEX_INIT(CvMUTEXP(PL_compcv));
6314 #endif /* USE_THREADS */
6316 return oldsavestack_ix;
6335 char *context = NULL;
6339 if (!yychar || (yychar == ';' && !PL_rsfp))
6341 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6342 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6343 while (isSPACE(*PL_oldoldbufptr))
6345 context = PL_oldoldbufptr;
6346 contlen = PL_bufptr - PL_oldoldbufptr;
6348 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6349 PL_oldbufptr != PL_bufptr) {
6350 while (isSPACE(*PL_oldbufptr))
6352 context = PL_oldbufptr;
6353 contlen = PL_bufptr - PL_oldbufptr;
6355 else if (yychar > 255)
6356 where = "next token ???";
6357 else if ((yychar & 127) == 127) {
6358 if (PL_lex_state == LEX_NORMAL ||
6359 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6360 where = "at end of line";
6361 else if (PL_lex_inpat)
6362 where = "within pattern";
6364 where = "within string";
6367 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6369 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6370 else if (isPRINT_LC(yychar))
6371 sv_catpvf(where_sv, "%c", yychar);
6373 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6374 where = SvPVX(where_sv);
6376 msg = sv_2mortal(newSVpv(s, 0));
6377 sv_catpvf(msg, " at %_ line %ld, ",
6378 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6380 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6382 sv_catpvf(msg, "%s\n", where);
6383 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6385 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6386 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6391 else if (PL_in_eval)
6392 sv_catsv(ERRSV, msg);
6394 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6395 if (++PL_error_count >= 10)
6396 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6398 PL_in_my_stash = Nullhv;