3 * Copyright (c) 1991-1999, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It all comes from here, the stench and the peril." --Frodo
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 /* In variables name $^X, these are the legal values for X.
78 * 1999-02-27 mjd-perl-patch@plover.com */
79 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
81 /* The following are arranged oddly so that the guard on the switch statement
82 * can get by with a single comparison (if the compiler is smart enough).
85 /* #define LEX_NOTPARSING 11 is done in perl.h. */
88 #define LEX_INTERPNORMAL 9
89 #define LEX_INTERPCASEMOD 8
90 #define LEX_INTERPPUSH 7
91 #define LEX_INTERPSTART 6
92 #define LEX_INTERPEND 5
93 #define LEX_INTERPENDMAYBE 4
94 #define LEX_INTERPCONCAT 3
95 #define LEX_INTERPCONST 2
96 #define LEX_FORMLINE 1
97 #define LEX_KNOWNEXT 0
103 #include <sys/file.h>
106 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
108 # include <unistd.h> /* Needed for execv() */
116 #ifdef USE_PURE_BISON
117 YYSTYPE* yylval_pointer = NULL;
118 int* yychar_pointer = NULL;
121 # define yylval (*yylval_pointer)
122 # define yychar (*yychar_pointer)
123 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
125 # define PERL_YYLEX_PARAM
128 #include "keywords.h"
133 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
135 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
136 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
137 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
138 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
139 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
140 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
141 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
142 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
143 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
144 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
145 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
146 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
147 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
148 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
149 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
150 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
151 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
152 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
153 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
154 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
156 /* This bit of chicanery makes a unary function followed by
157 * a parenthesis into a function with one argument, highest precedence.
159 #define UNI(f) return(yylval.ival = f, \
162 PL_last_uni = PL_oldbufptr, \
163 PL_last_lop_op = f, \
164 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
166 #define UNIBRACK(f) return(yylval.ival = f, \
168 PL_last_uni = PL_oldbufptr, \
169 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
171 /* grandfather return to old style */
172 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
177 if (*PL_bufptr == '=') {
179 if (toketype == ANDAND)
180 yylval.ival = OP_ANDASSIGN;
181 else if (toketype == OROR)
182 yylval.ival = OP_ORASSIGN;
189 no_op(char *what, char *s)
191 char *oldbp = PL_bufptr;
192 bool is_first = (PL_oldbufptr == PL_linestart);
195 yywarn(form("%s found where operator expected", what));
197 warn("\t(Missing semicolon on previous line?)\n");
198 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
200 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
201 if (t < PL_bufptr && isSPACE(*t))
202 warn("\t(Do you need to predeclare %.*s?)\n",
203 t - PL_oldoldbufptr, PL_oldoldbufptr);
207 warn("\t(Missing operator before end of line?)\n");
209 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
219 char *nl = strrchr(s,'\n');
225 iscntrl(PL_multi_close)
227 PL_multi_close < 32 || PL_multi_close == 127
231 tmpbuf[1] = toCTRL(PL_multi_close);
237 *tmpbuf = PL_multi_close;
241 q = strchr(s,'"') ? '\'' : '"';
242 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
249 if (ckWARN(WARN_DEPRECATED))
250 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
256 deprecate("comma-less variable list");
262 win32_textfilter(int idx, SV *sv, int maxlen)
264 I32 count = FILTER_READ(idx+1, sv, maxlen);
265 if (count > 0 && !maxlen)
266 win32_strip_return(sv);
274 utf16_textfilter(int idx, SV *sv, int maxlen)
276 I32 count = FILTER_READ(idx+1, sv, maxlen);
280 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
281 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
282 sv_usepvn(sv, (char*)tmps, tend - tmps);
289 utf16rev_textfilter(int idx, SV *sv, int maxlen)
291 I32 count = FILTER_READ(idx+1, sv, maxlen);
295 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
296 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
297 sv_usepvn(sv, (char*)tmps, tend - tmps);
312 SAVEI32(PL_lex_dojoin);
313 SAVEI32(PL_lex_brackets);
314 SAVEI32(PL_lex_fakebrack);
315 SAVEI32(PL_lex_casemods);
316 SAVEI32(PL_lex_starts);
317 SAVEI32(PL_lex_state);
318 SAVESPTR(PL_lex_inpat);
319 SAVEI32(PL_lex_inwhat);
320 SAVEI16(PL_curcop->cop_line);
323 SAVEPPTR(PL_oldbufptr);
324 SAVEPPTR(PL_oldoldbufptr);
325 SAVEPPTR(PL_linestart);
326 SAVESPTR(PL_linestr);
327 SAVEPPTR(PL_lex_brackstack);
328 SAVEPPTR(PL_lex_casestack);
329 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
330 SAVESPTR(PL_lex_stuff);
331 SAVEI32(PL_lex_defer);
332 SAVESPTR(PL_lex_repl);
333 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
334 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
336 PL_lex_state = LEX_NORMAL;
340 PL_lex_fakebrack = 0;
341 New(899, PL_lex_brackstack, 120, char);
342 New(899, PL_lex_casestack, 12, char);
343 SAVEFREEPV(PL_lex_brackstack);
344 SAVEFREEPV(PL_lex_casestack);
346 *PL_lex_casestack = '\0';
349 PL_lex_stuff = Nullsv;
350 PL_lex_repl = Nullsv;
354 if (SvREADONLY(PL_linestr))
355 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
356 s = SvPV(PL_linestr, len);
357 if (len && s[len-1] != ';') {
358 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
359 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
360 sv_catpvn(PL_linestr, "\n;", 2);
362 SvTEMP_off(PL_linestr);
363 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
364 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
366 PL_rs = newSVpvn("\n", 1);
373 PL_doextract = FALSE;
377 restore_rsfp(void *f)
379 PerlIO *fp = (PerlIO*)f;
381 if (PL_rsfp == PerlIO_stdin())
382 PerlIO_clearerr(PL_rsfp);
383 else if (PL_rsfp && (PL_rsfp != fp))
384 PerlIO_close(PL_rsfp);
389 restore_expect(void *e)
391 /* a safe way to store a small integer in a pointer */
392 PL_expect = (expectation)((char *)e - PL_tokenbuf);
396 restore_lex_expect(void *e)
398 /* a safe way to store a small integer in a pointer */
399 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
411 PL_curcop->cop_line++;
414 while (*s == ' ' || *s == '\t') s++;
415 if (strnEQ(s, "line ", 5)) {
424 while (*s == ' ' || *s == '\t')
426 if (*s == '"' && (t = strchr(s+1, '"')))
430 return; /* false alarm */
431 for (t = s; !isSPACE(*t); t++) ;
436 PL_curcop->cop_filegv = gv_fetchfile(s);
438 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
440 PL_curcop->cop_line = atoi(n)-1;
444 skipspace(register char *s)
447 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
448 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
454 while (s < PL_bufend && isSPACE(*s)) {
455 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
458 if (s < PL_bufend && *s == '#') {
459 while (s < PL_bufend && *s != '\n')
463 if (PL_in_eval && !PL_rsfp) {
469 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
471 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
472 if (PL_minus_n || PL_minus_p) {
473 sv_setpv(PL_linestr,PL_minus_p ?
474 ";}continue{print or die qq(-p destination: $!\\n)" :
476 sv_catpv(PL_linestr,";}");
477 PL_minus_n = PL_minus_p = 0;
480 sv_setpv(PL_linestr,";");
481 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
482 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
483 if (PL_preprocess && !PL_in_eval)
484 (void)PerlProc_pclose(PL_rsfp);
485 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
486 PerlIO_clearerr(PL_rsfp);
488 (void)PerlIO_close(PL_rsfp);
492 PL_linestart = PL_bufptr = s + prevlen;
493 PL_bufend = s + SvCUR(PL_linestr);
496 if (PERLDB_LINE && PL_curstash != PL_debstash) {
497 SV *sv = NEWSV(85,0);
499 sv_upgrade(sv, SVt_PVMG);
500 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
501 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
512 if (PL_oldoldbufptr != PL_last_uni)
514 while (isSPACE(*PL_last_uni))
516 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
517 if ((t = strchr(s, '(')) && t < PL_bufptr)
521 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
528 #define UNI(f) return uni(f,s)
536 PL_last_uni = PL_oldbufptr;
547 #endif /* CRIPPLED_CC */
549 #define LOP(f,x) return lop(f,x,s)
552 lop(I32 f, expectation x, char *s)
559 PL_last_lop = PL_oldbufptr;
575 PL_nexttype[PL_nexttoke] = type;
577 if (PL_lex_state != LEX_KNOWNEXT) {
578 PL_lex_defer = PL_lex_state;
579 PL_lex_expect = PL_expect;
580 PL_lex_state = LEX_KNOWNEXT;
585 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
590 start = skipspace(start);
592 if (isIDFIRST_lazy(s) ||
593 (allow_pack && *s == ':') ||
594 (allow_initial_tick && *s == '\'') )
596 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
597 if (check_keyword && keyword(PL_tokenbuf, len))
599 if (token == METHOD) {
604 PL_expect = XOPERATOR;
607 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
608 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
615 force_ident(register char *s, int kind)
618 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
619 PL_nextval[PL_nexttoke].opval = o;
622 dTHR; /* just for in_eval */
623 o->op_private = OPpCONST_ENTERED;
624 /* XXX see note in pp_entereval() for why we forgo typo
625 warnings if the symbol must be introduced in an eval.
627 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
628 kind == '$' ? SVt_PV :
629 kind == '@' ? SVt_PVAV :
630 kind == '%' ? SVt_PVHV :
638 force_version(char *s)
640 OP *version = Nullop;
644 /* default VERSION number -- GBARR */
649 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
650 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
652 /* real VERSION number -- GBARR */
653 version = yylval.opval;
657 /* NOTE: The parser sees the package name and the VERSION swapped */
658 PL_nextval[PL_nexttoke].opval = version;
676 s = SvPV_force(sv, len);
680 while (s < send && *s != '\\')
685 if ( PL_hints & HINT_NEW_STRING )
686 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
689 if (s + 1 < send && (s[1] == '\\'))
690 s++; /* all that, just for this */
695 SvCUR_set(sv, d - SvPVX(sv));
697 if ( PL_hints & HINT_NEW_STRING )
698 return new_constant(NULL, 0, "q", sv, pv, "q");
705 register I32 op_type = yylval.ival;
707 if (op_type == OP_NULL) {
708 yylval.opval = PL_lex_op;
712 if (op_type == OP_CONST || op_type == OP_READLINE) {
713 SV *sv = tokeq(PL_lex_stuff);
715 if (SvTYPE(sv) == SVt_PVIV) {
716 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
722 nsv = newSVpvn(p, len);
726 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
727 PL_lex_stuff = Nullsv;
731 PL_sublex_info.super_state = PL_lex_state;
732 PL_sublex_info.sub_inwhat = op_type;
733 PL_sublex_info.sub_op = PL_lex_op;
734 PL_lex_state = LEX_INTERPPUSH;
738 yylval.opval = PL_lex_op;
752 PL_lex_state = PL_sublex_info.super_state;
753 SAVEI32(PL_lex_dojoin);
754 SAVEI32(PL_lex_brackets);
755 SAVEI32(PL_lex_fakebrack);
756 SAVEI32(PL_lex_casemods);
757 SAVEI32(PL_lex_starts);
758 SAVEI32(PL_lex_state);
759 SAVESPTR(PL_lex_inpat);
760 SAVEI32(PL_lex_inwhat);
761 SAVEI16(PL_curcop->cop_line);
763 SAVEPPTR(PL_oldbufptr);
764 SAVEPPTR(PL_oldoldbufptr);
765 SAVEPPTR(PL_linestart);
766 SAVESPTR(PL_linestr);
767 SAVEPPTR(PL_lex_brackstack);
768 SAVEPPTR(PL_lex_casestack);
770 PL_linestr = PL_lex_stuff;
771 PL_lex_stuff = Nullsv;
773 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
774 PL_bufend += SvCUR(PL_linestr);
775 SAVEFREESV(PL_linestr);
777 PL_lex_dojoin = FALSE;
779 PL_lex_fakebrack = 0;
780 New(899, PL_lex_brackstack, 120, char);
781 New(899, PL_lex_casestack, 12, char);
782 SAVEFREEPV(PL_lex_brackstack);
783 SAVEFREEPV(PL_lex_casestack);
785 *PL_lex_casestack = '\0';
787 PL_lex_state = LEX_INTERPCONCAT;
788 PL_curcop->cop_line = PL_multi_start;
790 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
791 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
792 PL_lex_inpat = PL_sublex_info.sub_op;
794 PL_lex_inpat = Nullop;
802 if (!PL_lex_starts++) {
803 PL_expect = XOPERATOR;
804 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
808 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
809 PL_lex_state = LEX_INTERPCASEMOD;
810 return yylex(PERL_YYLEX_PARAM);
813 /* Is there a right-hand side to take care of? */
814 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
815 PL_linestr = PL_lex_repl;
817 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
818 PL_bufend += SvCUR(PL_linestr);
819 SAVEFREESV(PL_linestr);
820 PL_lex_dojoin = FALSE;
822 PL_lex_fakebrack = 0;
824 *PL_lex_casestack = '\0';
826 if (SvCOMPILED(PL_lex_repl)) {
827 PL_lex_state = LEX_INTERPNORMAL;
829 /* we don't clear PL_lex_repl here, so that we can check later
830 whether this is an evalled subst; that means we rely on the
831 logic to ensure sublex_done() is called again only via the
832 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
835 PL_lex_state = LEX_INTERPCONCAT;
836 PL_lex_repl = Nullsv;
842 PL_bufend = SvPVX(PL_linestr);
843 PL_bufend += SvCUR(PL_linestr);
844 PL_expect = XOPERATOR;
852 Extracts a pattern, double-quoted string, or transliteration. This
855 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
856 processing a pattern (PL_lex_inpat is true), a transliteration
857 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
859 Returns a pointer to the character scanned up to. Iff this is
860 advanced from the start pointer supplied (ie if anything was
861 successfully parsed), will leave an OP for the substring scanned
862 in yylval. Caller must intuit reason for not parsing further
863 by looking at the next characters herself.
867 double-quoted style: \r and \n
868 regexp special ones: \D \s
870 backrefs: \1 (deprecated in substitution replacements)
871 case and quoting: \U \Q \E
872 stops on @ and $, but not for $ as tail anchor
875 characters are VERY literal, except for - not at the start or end
876 of the string, which indicates a range. scan_const expands the
877 range to the full set of intermediate characters.
879 In double-quoted strings:
881 double-quoted style: \r and \n
883 backrefs: \1 (deprecated)
884 case and quoting: \U \Q \E
887 scan_const does *not* construct ops to handle interpolated strings.
888 It stops processing as soon as it finds an embedded $ or @ variable
889 and leaves it to the caller to work out what's going on.
891 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
893 $ in pattern could be $foo or could be tail anchor. Assumption:
894 it's a tail anchor if $ is the last thing in the string, or if it's
895 followed by one of ")| \n\t"
897 \1 (backreferences) are turned into $1
899 The structure of the code is
900 while (there's a character to process) {
901 handle transliteration ranges
903 skip # initiated comments in //x patterns
904 check for embedded @foo
905 check for embedded scalars
907 leave intact backslashes from leave (below)
908 deprecate \1 in strings and sub replacements
909 handle string-changing backslashes \l \U \Q \E, etc.
910 switch (what was escaped) {
911 handle - in a transliteration (becomes a literal -)
912 handle \132 octal characters
913 handle 0x15 hex characters
914 handle \cV (control V)
915 handle printf backslashes (\f, \r, \n, etc)
918 } (end while character to read)
923 scan_const(char *start)
925 register char *send = PL_bufend; /* end of the constant */
926 SV *sv = NEWSV(93, send - start); /* sv for the constant */
927 register char *s = start; /* start of the constant */
928 register char *d = SvPVX(sv); /* destination for copies */
929 bool dorange = FALSE; /* are we in a translit range? */
931 I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
932 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
934 I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
935 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
938 /* leaveit is the set of acceptably-backslashed characters */
941 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
944 while (s < send || dorange) {
945 /* get transliterations out of the way (they're most literal) */
946 if (PL_lex_inwhat == OP_TRANS) {
947 /* expand a range A-Z to the full set of characters. AIE! */
949 I32 i; /* current expanded character */
950 I32 min; /* first character in range */
951 I32 max; /* last character in range */
953 i = d - SvPVX(sv); /* remember current offset */
954 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
955 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
956 d -= 2; /* eat the first char and the - */
958 min = (U8)*d; /* first char in range */
959 max = (U8)d[1]; /* last char in range */
962 if ((isLOWER(min) && isLOWER(max)) ||
963 (isUPPER(min) && isUPPER(max))) {
965 for (i = min; i <= max; i++)
969 for (i = min; i <= max; i++)
976 for (i = min; i <= max; i++)
979 /* mark the range as done, and continue */
984 /* range begins (ignore - as first or last char) */
985 else if (*s == '-' && s+1 < send && s != start) {
987 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
996 /* if we get here, we're not doing a transliteration */
998 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
999 except for the last char, which will be done separately. */
1000 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1002 while (s < send && *s != ')')
1004 } else if (s[2] == '{'
1005 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1007 char *regparse = s + (s[2] == '{' ? 3 : 4);
1010 while (count && (c = *regparse)) {
1011 if (c == '\\' && regparse[1])
1019 if (*regparse != ')') {
1020 regparse--; /* Leave one char for continuation. */
1021 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1023 while (s < regparse)
1028 /* likewise skip #-initiated comments in //x patterns */
1029 else if (*s == '#' && PL_lex_inpat &&
1030 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1031 while (s+1 < send && *s != '\n')
1035 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1036 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1039 /* check for embedded scalars. only stop if we're sure it's a
1042 else if (*s == '$') {
1043 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1045 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1046 break; /* in regexp, $ might be tail anchor */
1049 /* (now in tr/// code again) */
1051 if (*s & 0x80 && thisutf) {
1052 dTHR; /* only for ckWARN */
1053 if (ckWARN(WARN_UTF8)) {
1054 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1064 if (*s == '\\' && s+1 < send) {
1067 /* some backslashes we leave behind */
1068 if (*leaveit && *s && strchr(leaveit, *s)) {
1074 /* deprecate \1 in strings and substitution replacements */
1075 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1076 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1078 dTHR; /* only for ckWARN */
1079 if (ckWARN(WARN_SYNTAX))
1080 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1085 /* string-change backslash escapes */
1086 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1091 /* if we get here, it's either a quoted -, or a digit */
1094 /* quoted - in transliterations */
1096 if (PL_lex_inwhat == OP_TRANS) {
1104 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1106 "Unrecognized escape \\%c passed through",
1108 /* default action is to copy the quoted character */
1113 /* \132 indicates an octal constant */
1114 case '0': case '1': case '2': case '3':
1115 case '4': case '5': case '6': case '7':
1116 *d++ = scan_oct(s, 3, &len);
1120 /* \x24 indicates a hex constant */
1124 char* e = strchr(s, '}');
1127 yyerror("Missing right brace on \\x{}");
1132 if (ckWARN(WARN_UTF8))
1134 "Use of \\x{} without utf8 declaration");
1136 /* note: utf always shorter than hex */
1137 d = (char*)uv_to_utf8((U8*)d,
1138 scan_hex(s + 1, e - s - 1, &len));
1143 UV uv = (UV)scan_hex(s, 2, &len);
1144 if (utf && PL_lex_inwhat == OP_TRANS &&
1145 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1147 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1150 if (uv >= 127 && UTF) {
1152 if (ckWARN(WARN_UTF8))
1154 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1163 /* \c is a control character */
1177 /* printf-style backslashes, formfeeds, newlines, etc */
1203 } /* end if (backslash) */
1206 } /* while loop to process each character */
1208 /* terminate the string and set up the sv */
1210 SvCUR_set(sv, d - SvPVX(sv));
1213 /* shrink the sv if we allocated more than we used */
1214 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1215 SvLEN_set(sv, SvCUR(sv) + 1);
1216 Renew(SvPVX(sv), SvLEN(sv), char);
1219 /* return the substring (via yylval) only if we parsed anything */
1220 if (s > PL_bufptr) {
1221 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1222 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1224 ( PL_lex_inwhat == OP_TRANS
1226 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1229 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1235 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1237 intuit_more(register char *s)
1239 if (PL_lex_brackets)
1241 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1243 if (*s != '{' && *s != '[')
1248 /* In a pattern, so maybe we have {n,m}. */
1265 /* On the other hand, maybe we have a character class */
1268 if (*s == ']' || *s == '^')
1271 int weight = 2; /* let's weigh the evidence */
1273 unsigned char un_char = 255, last_un_char;
1274 char *send = strchr(s,']');
1275 char tmpbuf[sizeof PL_tokenbuf * 4];
1277 if (!send) /* has to be an expression */
1280 Zero(seen,256,char);
1283 else if (isDIGIT(*s)) {
1285 if (isDIGIT(s[1]) && s[2] == ']')
1291 for (; s < send; s++) {
1292 last_un_char = un_char;
1293 un_char = (unsigned char)*s;
1298 weight -= seen[un_char] * 10;
1299 if (isALNUM_lazy(s+1)) {
1300 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1301 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1306 else if (*s == '$' && s[1] &&
1307 strchr("[#!%*<>()-=",s[1])) {
1308 if (/*{*/ strchr("])} =",s[2]))
1317 if (strchr("wds]",s[1]))
1319 else if (seen['\''] || seen['"'])
1321 else if (strchr("rnftbxcav",s[1]))
1323 else if (isDIGIT(s[1])) {
1325 while (s[1] && isDIGIT(s[1]))
1335 if (strchr("aA01! ",last_un_char))
1337 if (strchr("zZ79~",s[1]))
1339 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1340 weight -= 5; /* cope with negative subscript */
1343 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1344 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1349 if (keyword(tmpbuf, d - tmpbuf))
1352 if (un_char == last_un_char + 1)
1354 weight -= seen[un_char];
1359 if (weight >= 0) /* probably a character class */
1367 intuit_method(char *start, GV *gv)
1369 char *s = start + (*start == '$');
1370 char tmpbuf[sizeof PL_tokenbuf];
1378 if ((cv = GvCVu(gv))) {
1379 char *proto = SvPVX(cv);
1389 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1390 if (*start == '$') {
1391 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1396 return *s == '(' ? FUNCMETH : METHOD;
1398 if (!keyword(tmpbuf, len)) {
1399 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1404 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1405 if (indirgv && GvCVu(indirgv))
1407 /* filehandle or package name makes it a method */
1408 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1410 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1411 return 0; /* no assumptions -- "=>" quotes bearword */
1413 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1414 newSVpvn(tmpbuf,len));
1415 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1419 return *s == '(' ? FUNCMETH : METHOD;
1429 char *pdb = PerlEnv_getenv("PERL5DB");
1433 SETERRNO(0,SS$_NORMAL);
1434 return "BEGIN { require 'perl5db.pl' }";
1440 /* Encoded script support. filter_add() effectively inserts a
1441 * 'pre-processing' function into the current source input stream.
1442 * Note that the filter function only applies to the current source file
1443 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1445 * The datasv parameter (which may be NULL) can be used to pass
1446 * private data to this instance of the filter. The filter function
1447 * can recover the SV using the FILTER_DATA macro and use it to
1448 * store private buffers and state information.
1450 * The supplied datasv parameter is upgraded to a PVIO type
1451 * and the IoDIRP field is used to store the function pointer.
1452 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1453 * private use must be set using malloc'd pointers.
1457 filter_add(filter_t funcp, SV *datasv)
1459 if (!funcp){ /* temporary handy debugging hack to be deleted */
1460 PL_filter_debug = atoi((char*)datasv);
1463 if (!PL_rsfp_filters)
1464 PL_rsfp_filters = newAV();
1466 datasv = NEWSV(255,0);
1467 if (!SvUPGRADE(datasv, SVt_PVIO))
1468 die("Can't upgrade filter_add data to SVt_PVIO");
1469 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1470 if (PL_filter_debug) {
1472 warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1474 av_unshift(PL_rsfp_filters, 1);
1475 av_store(PL_rsfp_filters, 0, datasv) ;
1480 /* Delete most recently added instance of this filter function. */
1482 filter_del(filter_t funcp)
1484 if (PL_filter_debug)
1485 warn("filter_del func %p", funcp);
1486 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1488 /* if filter is on top of stack (usual case) just pop it off */
1489 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1490 sv_free(av_pop(PL_rsfp_filters));
1494 /* we need to search for the correct entry and clear it */
1495 die("filter_del can only delete in reverse order (currently)");
1499 /* Invoke the n'th filter function for the current rsfp. */
1501 filter_read(int idx, SV *buf_sv, int maxlen)
1504 /* 0 = read one text line */
1509 if (!PL_rsfp_filters)
1511 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1512 /* Provide a default input filter to make life easy. */
1513 /* Note that we append to the line. This is handy. */
1514 if (PL_filter_debug)
1515 warn("filter_read %d: from rsfp\n", idx);
1519 int old_len = SvCUR(buf_sv) ;
1521 /* ensure buf_sv is large enough */
1522 SvGROW(buf_sv, old_len + maxlen) ;
1523 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1524 if (PerlIO_error(PL_rsfp))
1525 return -1; /* error */
1527 return 0 ; /* end of file */
1529 SvCUR_set(buf_sv, old_len + len) ;
1532 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1533 if (PerlIO_error(PL_rsfp))
1534 return -1; /* error */
1536 return 0 ; /* end of file */
1539 return SvCUR(buf_sv);
1541 /* Skip this filter slot if filter has been deleted */
1542 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1543 if (PL_filter_debug)
1544 warn("filter_read %d: skipped (filter deleted)\n", idx);
1545 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1547 /* Get function pointer hidden within datasv */
1548 funcp = (filter_t)IoDIRP(datasv);
1549 if (PL_filter_debug) {
1551 warn("filter_read %d: via function %p (%s)\n",
1552 idx, funcp, SvPV(datasv,n_a));
1554 /* Call function. The function is expected to */
1555 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1556 /* Return: <0:error, =0:eof, >0:not eof */
1557 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1561 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1564 if (!PL_rsfp_filters) {
1565 filter_add(win32_textfilter,NULL);
1568 if (PL_rsfp_filters) {
1571 SvCUR_set(sv, 0); /* start with empty line */
1572 if (FILTER_READ(0, sv, 0) > 0)
1573 return ( SvPVX(sv) ) ;
1578 return (sv_gets(sv, fp, append));
1583 static char* exp_name[] =
1584 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1590 Works out what to call the token just pulled out of the input
1591 stream. The yacc parser takes care of taking the ops we return and
1592 stitching them into a tree.
1598 if read an identifier
1599 if we're in a my declaration
1600 croak if they tried to say my($foo::bar)
1601 build the ops for a my() declaration
1602 if it's an access to a my() variable
1603 are we in a sort block?
1604 croak if my($a); $a <=> $b
1605 build ops for access to a my() variable
1606 if in a dq string, and they've said @foo and we can't find @foo
1608 build ops for a bareword
1609 if we already built the token before, use it.
1612 int yylex(PERL_YYLEX_PARAM_DECL)
1622 #ifdef USE_PURE_BISON
1623 yylval_pointer = lvalp;
1624 yychar_pointer = lcharp;
1627 /* check if there's an identifier for us to look at */
1628 if (PL_pending_ident) {
1629 /* pit holds the identifier we read and pending_ident is reset */
1630 char pit = PL_pending_ident;
1631 PL_pending_ident = 0;
1633 /* if we're in a my(), we can't allow dynamics here.
1634 $foo'bar has already been turned into $foo::bar, so
1635 just check for colons.
1637 if it's a legal name, the OP is a PADANY.
1640 if (strchr(PL_tokenbuf,':'))
1641 yyerror(form(PL_no_myglob,PL_tokenbuf));
1643 yylval.opval = newOP(OP_PADANY, 0);
1644 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1649 build the ops for accesses to a my() variable.
1651 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1652 then used in a comparison. This catches most, but not
1653 all cases. For instance, it catches
1654 sort { my($a); $a <=> $b }
1656 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1657 (although why you'd do that is anyone's guess).
1660 if (!strchr(PL_tokenbuf,':')) {
1662 /* Check for single character per-thread SVs */
1663 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1664 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1665 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1667 yylval.opval = newOP(OP_THREADSV, 0);
1668 yylval.opval->op_targ = tmp;
1671 #endif /* USE_THREADS */
1672 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1673 /* if it's a sort block and they're naming $a or $b */
1674 if (PL_last_lop_op == OP_SORT &&
1675 PL_tokenbuf[0] == '$' &&
1676 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1679 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1680 d < PL_bufend && *d != '\n';
1683 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1684 croak("Can't use \"my %s\" in sort comparison",
1690 yylval.opval = newOP(OP_PADANY, 0);
1691 yylval.opval->op_targ = tmp;
1697 Whine if they've said @foo in a doublequoted string,
1698 and @foo isn't a variable we can find in the symbol
1701 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1702 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1703 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1704 yyerror(form("In string, %s now must be written as \\%s",
1705 PL_tokenbuf, PL_tokenbuf));
1708 /* build ops for a bareword */
1709 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1710 yylval.opval->op_private = OPpCONST_ENTERED;
1711 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1712 ((PL_tokenbuf[0] == '$') ? SVt_PV
1713 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1718 /* no identifier pending identification */
1720 switch (PL_lex_state) {
1722 case LEX_NORMAL: /* Some compilers will produce faster */
1723 case LEX_INTERPNORMAL: /* code if we comment these out. */
1727 /* when we're already built the next token, just pull it out the queue */
1730 yylval = PL_nextval[PL_nexttoke];
1732 PL_lex_state = PL_lex_defer;
1733 PL_expect = PL_lex_expect;
1734 PL_lex_defer = LEX_NORMAL;
1736 return(PL_nexttype[PL_nexttoke]);
1738 /* interpolated case modifiers like \L \U, including \Q and \E.
1739 when we get here, PL_bufptr is at the \
1741 case LEX_INTERPCASEMOD:
1743 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1744 croak("panic: INTERPCASEMOD");
1746 /* handle \E or end of string */
1747 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1751 if (PL_lex_casemods) {
1752 oldmod = PL_lex_casestack[--PL_lex_casemods];
1753 PL_lex_casestack[PL_lex_casemods] = '\0';
1755 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1757 PL_lex_state = LEX_INTERPCONCAT;
1761 if (PL_bufptr != PL_bufend)
1763 PL_lex_state = LEX_INTERPCONCAT;
1764 return yylex(PERL_YYLEX_PARAM);
1768 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1769 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1770 if (strchr("LU", *s) &&
1771 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1773 PL_lex_casestack[--PL_lex_casemods] = '\0';
1776 if (PL_lex_casemods > 10) {
1777 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1778 if (newlb != PL_lex_casestack) {
1780 PL_lex_casestack = newlb;
1783 PL_lex_casestack[PL_lex_casemods++] = *s;
1784 PL_lex_casestack[PL_lex_casemods] = '\0';
1785 PL_lex_state = LEX_INTERPCONCAT;
1786 PL_nextval[PL_nexttoke].ival = 0;
1789 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1791 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1793 PL_nextval[PL_nexttoke].ival = OP_LC;
1795 PL_nextval[PL_nexttoke].ival = OP_UC;
1797 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1799 croak("panic: yylex");
1802 if (PL_lex_starts) {
1808 return yylex(PERL_YYLEX_PARAM);
1811 case LEX_INTERPPUSH:
1812 return sublex_push();
1814 case LEX_INTERPSTART:
1815 if (PL_bufptr == PL_bufend)
1816 return sublex_done();
1818 PL_lex_dojoin = (*PL_bufptr == '@');
1819 PL_lex_state = LEX_INTERPNORMAL;
1820 if (PL_lex_dojoin) {
1821 PL_nextval[PL_nexttoke].ival = 0;
1824 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1825 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1826 force_next(PRIVATEREF);
1828 force_ident("\"", '$');
1829 #endif /* USE_THREADS */
1830 PL_nextval[PL_nexttoke].ival = 0;
1832 PL_nextval[PL_nexttoke].ival = 0;
1834 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1837 if (PL_lex_starts++) {
1841 return yylex(PERL_YYLEX_PARAM);
1843 case LEX_INTERPENDMAYBE:
1844 if (intuit_more(PL_bufptr)) {
1845 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1851 if (PL_lex_dojoin) {
1852 PL_lex_dojoin = FALSE;
1853 PL_lex_state = LEX_INTERPCONCAT;
1856 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
1857 && SvCOMPILED(PL_lex_repl))
1859 if (PL_bufptr != PL_bufend)
1860 croak("Bad evalled substitution pattern");
1861 PL_lex_repl = Nullsv;
1864 case LEX_INTERPCONCAT:
1866 if (PL_lex_brackets)
1867 croak("panic: INTERPCONCAT");
1869 if (PL_bufptr == PL_bufend)
1870 return sublex_done();
1872 if (SvIVX(PL_linestr) == '\'') {
1873 SV *sv = newSVsv(PL_linestr);
1876 else if ( PL_hints & HINT_NEW_RE )
1877 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1878 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1882 s = scan_const(PL_bufptr);
1884 PL_lex_state = LEX_INTERPCASEMOD;
1886 PL_lex_state = LEX_INTERPSTART;
1889 if (s != PL_bufptr) {
1890 PL_nextval[PL_nexttoke] = yylval;
1893 if (PL_lex_starts++)
1897 return yylex(PERL_YYLEX_PARAM);
1901 return yylex(PERL_YYLEX_PARAM);
1903 PL_lex_state = LEX_NORMAL;
1904 s = scan_formline(PL_bufptr);
1905 if (!PL_lex_formbrack)
1911 PL_oldoldbufptr = PL_oldbufptr;
1914 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1920 if (isIDFIRST_lazy(s))
1922 croak("Unrecognized character \\x%02X", *s & 255);
1925 goto fake_eof; /* emulate EOF on ^D or ^Z */
1930 if (PL_lex_brackets)
1931 yyerror("Missing right curly or square bracket");
1934 if (s++ < PL_bufend)
1935 goto retry; /* ignore stray nulls */
1938 if (!PL_in_eval && !PL_preambled) {
1939 PL_preambled = TRUE;
1940 sv_setpv(PL_linestr,incl_perldb());
1941 if (SvCUR(PL_linestr))
1942 sv_catpv(PL_linestr,";");
1944 while(AvFILLp(PL_preambleav) >= 0) {
1945 SV *tmpsv = av_shift(PL_preambleav);
1946 sv_catsv(PL_linestr, tmpsv);
1947 sv_catpv(PL_linestr, ";");
1950 sv_free((SV*)PL_preambleav);
1951 PL_preambleav = NULL;
1953 if (PL_minus_n || PL_minus_p) {
1954 sv_catpv(PL_linestr, "LINE: while (<>) {");
1956 sv_catpv(PL_linestr,"chomp;");
1958 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1960 GvIMPORTED_AV_on(gv);
1962 if (strchr("/'\"", *PL_splitstr)
1963 && strchr(PL_splitstr + 1, *PL_splitstr))
1964 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1967 s = "'~#\200\1'"; /* surely one char is unused...*/
1968 while (s[1] && strchr(PL_splitstr, *s)) s++;
1970 sv_catpvf(PL_linestr, "@F=split(%s%c",
1971 "q" + (delim == '\''), delim);
1972 for (s = PL_splitstr; *s; s++) {
1974 sv_catpvn(PL_linestr, "\\", 1);
1975 sv_catpvn(PL_linestr, s, 1);
1977 sv_catpvf(PL_linestr, "%c);", delim);
1981 sv_catpv(PL_linestr,"@F=split(' ');");
1984 sv_catpv(PL_linestr, "\n");
1985 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1986 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1987 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1988 SV *sv = NEWSV(85,0);
1990 sv_upgrade(sv, SVt_PVMG);
1991 sv_setsv(sv,PL_linestr);
1992 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1997 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2000 if (PL_preprocess && !PL_in_eval)
2001 (void)PerlProc_pclose(PL_rsfp);
2002 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2003 PerlIO_clearerr(PL_rsfp);
2005 (void)PerlIO_close(PL_rsfp);
2007 PL_doextract = FALSE;
2009 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2010 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2011 sv_catpv(PL_linestr,";}");
2012 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2013 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2014 PL_minus_n = PL_minus_p = 0;
2017 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2018 sv_setpv(PL_linestr,"");
2019 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2022 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2023 PL_doextract = FALSE;
2025 /* Incest with pod. */
2026 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2027 sv_setpv(PL_linestr, "");
2028 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2029 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2030 PL_doextract = FALSE;
2034 } while (PL_doextract);
2035 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2036 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2037 SV *sv = NEWSV(85,0);
2039 sv_upgrade(sv, SVt_PVMG);
2040 sv_setsv(sv,PL_linestr);
2041 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2043 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2044 if (PL_curcop->cop_line == 1) {
2045 while (s < PL_bufend && isSPACE(*s))
2047 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2051 if (*s == '#' && *(s+1) == '!')
2053 #ifdef ALTERNATE_SHEBANG
2055 static char as[] = ALTERNATE_SHEBANG;
2056 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2057 d = s + (sizeof(as) - 1);
2059 #endif /* ALTERNATE_SHEBANG */
2068 while (*d && !isSPACE(*d))
2072 #ifdef ARG_ZERO_IS_SCRIPT
2073 if (ipathend > ipath) {
2075 * HP-UX (at least) sets argv[0] to the script name,
2076 * which makes $^X incorrect. And Digital UNIX and Linux,
2077 * at least, set argv[0] to the basename of the Perl
2078 * interpreter. So, having found "#!", we'll set it right.
2080 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2081 assert(SvPOK(x) || SvGMAGICAL(x));
2082 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2083 sv_setpvn(x, ipath, ipathend - ipath);
2086 TAINT_NOT; /* $^X is always tainted, but that's OK */
2088 #endif /* ARG_ZERO_IS_SCRIPT */
2093 d = instr(s,"perl -");
2095 d = instr(s,"perl");
2096 #ifdef ALTERNATE_SHEBANG
2098 * If the ALTERNATE_SHEBANG on this system starts with a
2099 * character that can be part of a Perl expression, then if
2100 * we see it but not "perl", we're probably looking at the
2101 * start of Perl code, not a request to hand off to some
2102 * other interpreter. Similarly, if "perl" is there, but
2103 * not in the first 'word' of the line, we assume the line
2104 * contains the start of the Perl program.
2106 if (d && *s != '#') {
2108 while (*c && !strchr("; \t\r\n\f\v#", *c))
2111 d = Nullch; /* "perl" not in first word; ignore */
2113 *s = '#'; /* Don't try to parse shebang line */
2115 #endif /* ALTERNATE_SHEBANG */
2120 !instr(s,"indir") &&
2121 instr(PL_origargv[0],"perl"))
2127 while (s < PL_bufend && isSPACE(*s))
2129 if (s < PL_bufend) {
2130 Newz(899,newargv,PL_origargc+3,char*);
2132 while (s < PL_bufend && !isSPACE(*s))
2135 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2138 newargv = PL_origargv;
2140 PerlProc_execv(ipath, newargv);
2141 croak("Can't exec %s", ipath);
2144 U32 oldpdb = PL_perldb;
2145 bool oldn = PL_minus_n;
2146 bool oldp = PL_minus_p;
2148 while (*d && !isSPACE(*d)) d++;
2149 while (*d == ' ' || *d == '\t') d++;
2153 if (*d == 'M' || *d == 'm') {
2155 while (*d && !isSPACE(*d)) d++;
2156 croak("Too late for \"-%.*s\" option",
2159 d = moreswitches(d);
2161 if (PERLDB_LINE && !oldpdb ||
2162 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2163 /* if we have already added "LINE: while (<>) {",
2164 we must not do it again */
2166 sv_setpv(PL_linestr, "");
2167 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2168 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2169 PL_preambled = FALSE;
2171 (void)gv_fetchfile(PL_origfilename);
2178 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2180 PL_lex_state = LEX_FORMLINE;
2181 return yylex(PERL_YYLEX_PARAM);
2185 #ifdef PERL_STRICT_CR
2186 warn("Illegal character \\%03o (carriage return)", '\r');
2188 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2190 case ' ': case '\t': case '\f': case 013:
2195 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2197 while (s < d && *s != '\n')
2202 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2204 PL_lex_state = LEX_FORMLINE;
2205 return yylex(PERL_YYLEX_PARAM);
2214 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2219 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2222 if (strnEQ(s,"=>",2)) {
2223 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2224 OPERATOR('-'); /* unary minus */
2226 PL_last_uni = PL_oldbufptr;
2227 PL_last_lop_op = OP_FTEREAD; /* good enough */
2229 case 'r': FTST(OP_FTEREAD);
2230 case 'w': FTST(OP_FTEWRITE);
2231 case 'x': FTST(OP_FTEEXEC);
2232 case 'o': FTST(OP_FTEOWNED);
2233 case 'R': FTST(OP_FTRREAD);
2234 case 'W': FTST(OP_FTRWRITE);
2235 case 'X': FTST(OP_FTREXEC);
2236 case 'O': FTST(OP_FTROWNED);
2237 case 'e': FTST(OP_FTIS);
2238 case 'z': FTST(OP_FTZERO);
2239 case 's': FTST(OP_FTSIZE);
2240 case 'f': FTST(OP_FTFILE);
2241 case 'd': FTST(OP_FTDIR);
2242 case 'l': FTST(OP_FTLINK);
2243 case 'p': FTST(OP_FTPIPE);
2244 case 'S': FTST(OP_FTSOCK);
2245 case 'u': FTST(OP_FTSUID);
2246 case 'g': FTST(OP_FTSGID);
2247 case 'k': FTST(OP_FTSVTX);
2248 case 'b': FTST(OP_FTBLK);
2249 case 'c': FTST(OP_FTCHR);
2250 case 't': FTST(OP_FTTTY);
2251 case 'T': FTST(OP_FTTEXT);
2252 case 'B': FTST(OP_FTBINARY);
2253 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2254 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2255 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2257 croak("Unrecognized file test: -%c", (int)tmp);
2264 if (PL_expect == XOPERATOR)
2269 else if (*s == '>') {
2272 if (isIDFIRST_lazy(s)) {
2273 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2281 if (PL_expect == XOPERATOR)
2284 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2286 OPERATOR('-'); /* unary minus */
2293 if (PL_expect == XOPERATOR)
2298 if (PL_expect == XOPERATOR)
2301 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2307 if (PL_expect != XOPERATOR) {
2308 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2309 PL_expect = XOPERATOR;
2310 force_ident(PL_tokenbuf, '*');
2323 if (PL_expect == XOPERATOR) {
2327 PL_tokenbuf[0] = '%';
2328 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2329 if (!PL_tokenbuf[1]) {
2331 yyerror("Final % should be \\% or %name");
2334 PL_pending_ident = '%';
2356 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2357 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2362 if (PL_curcop->cop_line < PL_copline)
2363 PL_copline = PL_curcop->cop_line;
2374 if (PL_lex_brackets <= 0)
2375 yyerror("Unmatched right square bracket");
2378 if (PL_lex_state == LEX_INTERPNORMAL) {
2379 if (PL_lex_brackets == 0) {
2380 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2381 PL_lex_state = LEX_INTERPEND;
2388 if (PL_lex_brackets > 100) {
2389 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2390 if (newlb != PL_lex_brackstack) {
2392 PL_lex_brackstack = newlb;
2395 switch (PL_expect) {
2397 if (PL_lex_formbrack) {
2401 if (PL_oldoldbufptr == PL_last_lop)
2402 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2404 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2405 OPERATOR(HASHBRACK);
2407 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2410 PL_tokenbuf[0] = '\0';
2411 if (d < PL_bufend && *d == '-') {
2412 PL_tokenbuf[0] = '-';
2414 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2417 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2418 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2420 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2423 char minus = (PL_tokenbuf[0] == '-');
2424 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2431 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2435 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2440 if (PL_oldoldbufptr == PL_last_lop)
2441 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2443 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2446 OPERATOR(HASHBRACK);
2447 /* This hack serves to disambiguate a pair of curlies
2448 * as being a block or an anon hash. Normally, expectation
2449 * determines that, but in cases where we're not in a
2450 * position to expect anything in particular (like inside
2451 * eval"") we have to resolve the ambiguity. This code
2452 * covers the case where the first term in the curlies is a
2453 * quoted string. Most other cases need to be explicitly
2454 * disambiguated by prepending a `+' before the opening
2455 * curly in order to force resolution as an anon hash.
2457 * XXX should probably propagate the outer expectation
2458 * into eval"" to rely less on this hack, but that could
2459 * potentially break current behavior of eval"".
2463 if (*s == '\'' || *s == '"' || *s == '`') {
2464 /* common case: get past first string, handling escapes */
2465 for (t++; t < PL_bufend && *t != *s;)
2466 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2470 else if (*s == 'q') {
2473 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2474 && !isALNUM(*t)))) {
2476 char open, close, term;
2479 while (t < PL_bufend && isSPACE(*t))
2483 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2487 for (t++; t < PL_bufend; t++) {
2488 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2490 else if (*t == open)
2494 for (t++; t < PL_bufend; t++) {
2495 if (*t == '\\' && t+1 < PL_bufend)
2497 else if (*t == close && --brackets <= 0)
2499 else if (*t == open)
2505 else if (isIDFIRST_lazy(s)) {
2506 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2508 while (t < PL_bufend && isSPACE(*t))
2510 /* if comma follows first term, call it an anon hash */
2511 /* XXX it could be a comma expression with loop modifiers */
2512 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2513 || (*t == '=' && t[1] == '>')))
2514 OPERATOR(HASHBRACK);
2515 if (PL_expect == XREF)
2516 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2518 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2524 yylval.ival = PL_curcop->cop_line;
2525 if (isSPACE(*s) || *s == '#')
2526 PL_copline = NOLINE; /* invalidate current command line number */
2531 if (PL_lex_brackets <= 0)
2532 yyerror("Unmatched right curly bracket");
2534 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2535 if (PL_lex_brackets < PL_lex_formbrack)
2536 PL_lex_formbrack = 0;
2537 if (PL_lex_state == LEX_INTERPNORMAL) {
2538 if (PL_lex_brackets == 0) {
2539 if (PL_lex_fakebrack) {
2540 PL_lex_state = LEX_INTERPEND;
2542 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2544 if (*s == '-' && s[1] == '>')
2545 PL_lex_state = LEX_INTERPENDMAYBE;
2546 else if (*s != '[' && *s != '{')
2547 PL_lex_state = LEX_INTERPEND;
2550 if (PL_lex_brackets < PL_lex_fakebrack) {
2552 PL_lex_fakebrack = 0;
2553 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2563 if (PL_expect == XOPERATOR) {
2564 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2565 PL_curcop->cop_line--;
2566 warner(WARN_SEMICOLON, PL_warn_nosemi);
2567 PL_curcop->cop_line++;
2572 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2574 PL_expect = XOPERATOR;
2575 force_ident(PL_tokenbuf, '&');
2579 yylval.ival = (OPpENTERSUB_AMPER<<8);
2598 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2599 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2601 if (PL_expect == XSTATE && isALPHA(tmp) &&
2602 (s == PL_linestart+1 || s[-2] == '\n') )
2604 if (PL_in_eval && !PL_rsfp) {
2609 if (strnEQ(s,"=cut",4)) {
2623 PL_doextract = TRUE;
2626 if (PL_lex_brackets < PL_lex_formbrack) {
2628 #ifdef PERL_STRICT_CR
2629 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2631 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2633 if (*t == '\n' || *t == '#') {
2651 if (PL_expect != XOPERATOR) {
2652 if (s[1] != '<' && !strchr(s,'>'))
2655 s = scan_heredoc(s);
2657 s = scan_inputsymbol(s);
2658 TERM(sublex_start());
2663 SHop(OP_LEFT_SHIFT);
2677 SHop(OP_RIGHT_SHIFT);
2686 if (PL_expect == XOPERATOR) {
2687 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2690 return ','; /* grandfather non-comma-format format */
2694 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2695 if (PL_expect == XOPERATOR)
2696 no_op("Array length", PL_bufptr);
2697 PL_tokenbuf[0] = '@';
2698 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2700 if (!PL_tokenbuf[1])
2702 PL_expect = XOPERATOR;
2703 PL_pending_ident = '#';
2707 if (PL_expect == XOPERATOR)
2708 no_op("Scalar", PL_bufptr);
2709 PL_tokenbuf[0] = '$';
2710 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2711 if (!PL_tokenbuf[1]) {
2713 yyerror("Final $ should be \\$ or $name");
2717 /* This kludge not intended to be bulletproof. */
2718 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2719 yylval.opval = newSVOP(OP_CONST, 0,
2720 newSViv((IV)PL_compiling.cop_arybase));
2721 yylval.opval->op_private = OPpCONST_ARYBASE;
2727 if (PL_lex_state == LEX_NORMAL)
2730 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2733 PL_tokenbuf[0] = '@';
2734 if (ckWARN(WARN_SYNTAX)) {
2736 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2739 PL_bufptr = skipspace(PL_bufptr);
2740 while (t < PL_bufend && *t != ']')
2743 "Multidimensional syntax %.*s not supported",
2744 (t - PL_bufptr) + 1, PL_bufptr);
2748 else if (*s == '{') {
2749 PL_tokenbuf[0] = '%';
2750 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2751 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2753 char tmpbuf[sizeof PL_tokenbuf];
2755 for (t++; isSPACE(*t); t++) ;
2756 if (isIDFIRST_lazy(t)) {
2757 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2758 for (; isSPACE(*t); t++) ;
2759 if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
2761 "You need to quote \"%s\"", tmpbuf);
2767 PL_expect = XOPERATOR;
2768 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
2769 bool islop = (PL_last_lop == PL_oldoldbufptr);
2770 if (!islop || PL_last_lop_op == OP_GREPSTART)
2771 PL_expect = XOPERATOR;
2772 else if (strchr("$@\"'`q", *s))
2773 PL_expect = XTERM; /* e.g. print $fh "foo" */
2774 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2775 PL_expect = XTERM; /* e.g. print $fh &sub */
2776 else if (isIDFIRST_lazy(s)) {
2777 char tmpbuf[sizeof PL_tokenbuf];
2778 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2779 if (tmp = keyword(tmpbuf, len)) {
2780 /* binary operators exclude handle interpretations */
2792 PL_expect = XTERM; /* e.g. print $fh length() */
2797 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2798 if (gv && GvCVu(gv))
2799 PL_expect = XTERM; /* e.g. print $fh subr() */
2802 else if (isDIGIT(*s))
2803 PL_expect = XTERM; /* e.g. print $fh 3 */
2804 else if (*s == '.' && isDIGIT(s[1]))
2805 PL_expect = XTERM; /* e.g. print $fh .3 */
2806 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2807 PL_expect = XTERM; /* e.g. print $fh -1 */
2808 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2809 PL_expect = XTERM; /* print $fh <<"EOF" */
2811 PL_pending_ident = '$';
2815 if (PL_expect == XOPERATOR)
2817 PL_tokenbuf[0] = '@';
2818 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2819 if (!PL_tokenbuf[1]) {
2821 yyerror("Final @ should be \\@ or @name");
2824 if (PL_lex_state == LEX_NORMAL)
2826 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2828 PL_tokenbuf[0] = '%';
2830 /* Warn about @ where they meant $. */
2831 if (ckWARN(WARN_SYNTAX)) {
2832 if (*s == '[' || *s == '{') {
2834 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2836 if (*t == '}' || *t == ']') {
2838 PL_bufptr = skipspace(PL_bufptr);
2840 "Scalar value %.*s better written as $%.*s",
2841 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2846 PL_pending_ident = '@';
2849 case '/': /* may either be division or pattern */
2850 case '?': /* may either be conditional or pattern */
2851 if (PL_expect != XOPERATOR) {
2852 /* Disable warning on "study /blah/" */
2853 if (PL_oldoldbufptr == PL_last_uni
2854 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2855 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2857 s = scan_pat(s,OP_MATCH);
2858 TERM(sublex_start());
2866 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2867 #ifdef PERL_STRICT_CR
2870 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2872 && (s == PL_linestart || s[-1] == '\n') )
2874 PL_lex_formbrack = 0;
2878 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2884 yylval.ival = OPf_SPECIAL;
2890 if (PL_expect != XOPERATOR)
2895 case '0': case '1': case '2': case '3': case '4':
2896 case '5': case '6': case '7': case '8': case '9':
2898 if (PL_expect == XOPERATOR)
2904 if (PL_expect == XOPERATOR) {
2905 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2908 return ','; /* grandfather non-comma-format format */
2914 missingterm((char*)0);
2915 yylval.ival = OP_CONST;
2916 TERM(sublex_start());
2920 if (PL_expect == XOPERATOR) {
2921 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2924 return ','; /* grandfather non-comma-format format */
2930 missingterm((char*)0);
2931 yylval.ival = OP_CONST;
2932 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2933 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2934 yylval.ival = OP_STRINGIFY;
2938 TERM(sublex_start());
2942 if (PL_expect == XOPERATOR)
2943 no_op("Backticks",s);
2945 missingterm((char*)0);
2946 yylval.ival = OP_BACKTICK;
2948 TERM(sublex_start());
2952 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2953 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2955 if (PL_expect == XOPERATOR)
2956 no_op("Backslash",s);
2960 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3000 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3002 /* Some keywords can be followed by any delimiter, including ':' */
3003 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3004 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3005 (PL_tokenbuf[0] == 'q' &&
3006 strchr("qwxr", PL_tokenbuf[1]))));
3008 /* x::* is just a word, unless x is "CORE" */
3009 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3013 while (d < PL_bufend && isSPACE(*d))
3014 d++; /* no comments skipped here, or s### is misparsed */
3016 /* Is this a label? */
3017 if (!tmp && PL_expect == XSTATE
3018 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3020 yylval.pval = savepv(PL_tokenbuf);
3025 /* Check for keywords */
3026 tmp = keyword(PL_tokenbuf, len);
3028 /* Is this a word before a => operator? */
3029 if (strnEQ(d,"=>",2)) {
3031 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3032 yylval.opval->op_private = OPpCONST_BARE;
3036 if (tmp < 0) { /* second-class keyword? */
3037 GV *ogv = Nullgv; /* override (winner) */
3038 GV *hgv = Nullgv; /* hidden (loser) */
3039 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3041 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3044 if (GvIMPORTED_CV(gv))
3046 else if (! CvMETHOD(cv))
3050 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3051 (gv = *gvp) != (GV*)&PL_sv_undef &&
3052 GvCVu(gv) && GvIMPORTED_CV(gv))
3058 tmp = 0; /* overridden by import or by GLOBAL */
3061 && -tmp==KEY_lock /* XXX generalizable kludge */
3062 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3064 tmp = 0; /* any sub overrides "weak" keyword */
3066 else { /* no override */
3070 if (ckWARN(WARN_AMBIGUOUS) && hgv
3071 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3072 warner(WARN_AMBIGUOUS,
3073 "Ambiguous call resolved as CORE::%s(), %s",
3074 GvENAME(hgv), "qualify as such or use &");
3081 default: /* not a keyword */
3084 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3086 /* Get the rest if it looks like a package qualifier */
3088 if (*s == '\'' || *s == ':' && s[1] == ':') {
3090 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3093 croak("Bad name after %s%s", PL_tokenbuf,
3094 *s == '\'' ? "'" : "::");
3098 if (PL_expect == XOPERATOR) {
3099 if (PL_bufptr == PL_linestart) {
3100 PL_curcop->cop_line--;
3101 warner(WARN_SEMICOLON, PL_warn_nosemi);
3102 PL_curcop->cop_line++;
3105 no_op("Bareword",s);
3108 /* Look for a subroutine with this name in current package,
3109 unless name is "Foo::", in which case Foo is a bearword
3110 (and a package name). */
3113 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3115 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3117 "Bareword \"%s\" refers to nonexistent package",
3120 PL_tokenbuf[len] = '\0';
3127 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3130 /* if we saw a global override before, get the right name */
3133 sv = newSVpvn("CORE::GLOBAL::",14);
3134 sv_catpv(sv,PL_tokenbuf);
3137 sv = newSVpv(PL_tokenbuf,0);
3139 /* Presume this is going to be a bareword of some sort. */
3142 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3143 yylval.opval->op_private = OPpCONST_BARE;
3145 /* And if "Foo::", then that's what it certainly is. */
3150 /* See if it's the indirect object for a list operator. */
3152 if (PL_oldoldbufptr &&
3153 PL_oldoldbufptr < PL_bufptr &&
3154 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3155 /* NO SKIPSPACE BEFORE HERE! */
3157 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3158 || (PL_last_lop_op == OP_ENTERSUB
3160 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3162 bool immediate_paren = *s == '(';
3164 /* (Now we can afford to cross potential line boundary.) */
3167 /* Two barewords in a row may indicate method call. */
3169 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3172 /* If not a declared subroutine, it's an indirect object. */
3173 /* (But it's an indir obj regardless for sort.) */
3175 if ((PL_last_lop_op == OP_SORT ||
3176 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3177 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3178 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3183 /* If followed by a paren, it's certainly a subroutine. */
3185 PL_expect = XOPERATOR;
3189 if (gv && GvCVu(gv)) {
3191 if ((cv = GvCV(gv)) && SvPOK(cv))
3192 PL_last_proto = SvPV((SV*)cv, n_a);
3193 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3194 if (*d == ')' && (sv = cv_const_sv(cv))) {
3199 PL_nextval[PL_nexttoke].opval = yylval.opval;
3200 PL_expect = XOPERATOR;
3203 PL_last_lop_op = OP_ENTERSUB;
3207 /* If followed by var or block, call it a method (unless sub) */
3209 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3210 PL_last_lop = PL_oldbufptr;
3211 PL_last_lop_op = OP_METHOD;
3215 /* If followed by a bareword, see if it looks like indir obj. */
3217 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3220 /* Not a method, so call it a subroutine (if defined) */
3222 if (gv && GvCVu(gv)) {
3224 if (lastchar == '-')
3225 warn("Ambiguous use of -%s resolved as -&%s()",
3226 PL_tokenbuf, PL_tokenbuf);
3227 PL_last_lop = PL_oldbufptr;
3228 PL_last_lop_op = OP_ENTERSUB;
3229 /* Check for a constant sub */
3231 if ((sv = cv_const_sv(cv))) {
3233 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3234 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3235 yylval.opval->op_private = 0;
3239 /* Resolve to GV now. */
3240 op_free(yylval.opval);
3241 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3242 PL_last_lop_op = OP_ENTERSUB;
3243 /* Is there a prototype? */
3246 PL_last_proto = SvPV((SV*)cv, len);
3249 if (strEQ(PL_last_proto, "$"))
3251 if (*PL_last_proto == '&' && *s == '{') {
3252 sv_setpv(PL_subname,"__ANON__");
3256 PL_last_proto = NULL;
3257 PL_nextval[PL_nexttoke].opval = yylval.opval;
3263 if (PL_hints & HINT_STRICT_SUBS &&
3266 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3267 PL_last_lop_op != OP_ACCEPT &&
3268 PL_last_lop_op != OP_PIPE_OP &&
3269 PL_last_lop_op != OP_SOCKPAIR &&
3270 !(PL_last_lop_op == OP_ENTERSUB
3272 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3275 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3280 /* Call it a bare word */
3283 if (ckWARN(WARN_RESERVED)) {
3284 if (lastchar != '-') {
3285 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3287 warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
3292 if (lastchar && strchr("*%&", lastchar)) {
3293 warn("Operator or semicolon missing before %c%s",
3294 lastchar, PL_tokenbuf);
3295 warn("Ambiguous use of %c resolved as operator %c",
3296 lastchar, lastchar);
3302 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3303 newSVsv(GvSV(PL_curcop->cop_filegv)));
3307 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3308 newSVpvf("%ld", (long)PL_curcop->cop_line));
3311 case KEY___PACKAGE__:
3312 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3314 ? newSVsv(PL_curstname)
3323 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3324 char *pname = "main";
3325 if (PL_tokenbuf[2] == 'D')
3326 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3327 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3330 GvIOp(gv) = newIO();
3331 IoIFP(GvIOp(gv)) = PL_rsfp;
3332 #if defined(HAS_FCNTL) && defined(F_SETFD)
3334 int fd = PerlIO_fileno(PL_rsfp);
3335 fcntl(fd,F_SETFD,fd >= 3);
3338 /* Mark this internal pseudo-handle as clean */
3339 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3341 IoTYPE(GvIOp(gv)) = '|';
3342 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3343 IoTYPE(GvIOp(gv)) = '-';
3345 IoTYPE(GvIOp(gv)) = '<';
3356 if (PL_expect == XSTATE) {
3363 if (*s == ':' && s[1] == ':') {
3366 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3367 tmp = keyword(PL_tokenbuf, len);
3381 LOP(OP_ACCEPT,XTERM);
3387 LOP(OP_ATAN2,XTERM);
3396 LOP(OP_BLESS,XTERM);
3405 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3422 if (!PL_cryptseen++)
3425 LOP(OP_CRYPT,XTERM);
3428 if (ckWARN(WARN_OCTAL)) {
3429 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3430 if (*d != '0' && isDIGIT(*d))
3431 yywarn("chmod: mode argument is missing initial 0");
3433 LOP(OP_CHMOD,XTERM);
3436 LOP(OP_CHOWN,XTERM);
3439 LOP(OP_CONNECT,XTERM);
3455 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3459 PL_hints |= HINT_BLOCK_SCOPE;
3469 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3470 LOP(OP_DBMOPEN,XTERM);
3476 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3483 yylval.ival = PL_curcop->cop_line;
3497 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3498 UNIBRACK(OP_ENTEREVAL);
3513 case KEY_endhostent:
3519 case KEY_endservent:
3522 case KEY_endprotoent:
3533 yylval.ival = PL_curcop->cop_line;
3535 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3537 if ((PL_bufend - p) >= 3 &&
3538 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3541 if (isIDFIRST_lazy(p))
3542 croak("Missing $ on loop variable");
3547 LOP(OP_FORMLINE,XTERM);
3553 LOP(OP_FCNTL,XTERM);
3559 LOP(OP_FLOCK,XTERM);
3568 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3571 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3586 case KEY_getpriority:
3587 LOP(OP_GETPRIORITY,XTERM);
3589 case KEY_getprotobyname:
3592 case KEY_getprotobynumber:
3593 LOP(OP_GPBYNUMBER,XTERM);
3595 case KEY_getprotoent:
3607 case KEY_getpeername:
3608 UNI(OP_GETPEERNAME);
3610 case KEY_gethostbyname:
3613 case KEY_gethostbyaddr:
3614 LOP(OP_GHBYADDR,XTERM);
3616 case KEY_gethostent:
3619 case KEY_getnetbyname:
3622 case KEY_getnetbyaddr:
3623 LOP(OP_GNBYADDR,XTERM);
3628 case KEY_getservbyname:
3629 LOP(OP_GSBYNAME,XTERM);
3631 case KEY_getservbyport:
3632 LOP(OP_GSBYPORT,XTERM);
3634 case KEY_getservent:
3637 case KEY_getsockname:
3638 UNI(OP_GETSOCKNAME);
3640 case KEY_getsockopt:
3641 LOP(OP_GSOCKOPT,XTERM);
3663 yylval.ival = PL_curcop->cop_line;
3667 LOP(OP_INDEX,XTERM);
3673 LOP(OP_IOCTL,XTERM);
3685 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3716 LOP(OP_LISTEN,XTERM);
3725 s = scan_pat(s,OP_MATCH);
3726 TERM(sublex_start());
3729 LOP(OP_MAPSTART, XREF);
3732 LOP(OP_MKDIR,XTERM);
3735 LOP(OP_MSGCTL,XTERM);
3738 LOP(OP_MSGGET,XTERM);
3741 LOP(OP_MSGRCV,XTERM);
3744 LOP(OP_MSGSND,XTERM);
3749 if (isIDFIRST_lazy(s)) {
3750 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3751 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3752 if (!PL_in_my_stash) {
3755 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3762 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3769 if (PL_expect != XSTATE)
3770 yyerror("\"no\" not allowed in expression");
3771 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3772 s = force_version(s);
3781 if (isIDFIRST_lazy(s)) {
3783 for (d = s; isALNUM_lazy(d); d++) ;
3785 if (strchr("|&*+-=!?:.", *t))
3786 warn("Precedence problem: open %.*s should be open(%.*s)",
3792 yylval.ival = OP_OR;
3802 LOP(OP_OPEN_DIR,XTERM);
3805 checkcomma(s,PL_tokenbuf,"filehandle");
3809 checkcomma(s,PL_tokenbuf,"filehandle");
3828 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3832 LOP(OP_PIPE_OP,XTERM);
3837 missingterm((char*)0);
3838 yylval.ival = OP_CONST;
3839 TERM(sublex_start());
3847 missingterm((char*)0);
3849 if (SvCUR(PL_lex_stuff)) {
3852 d = SvPV_force(PL_lex_stuff, len);
3854 for (; isSPACE(*d) && len; --len, ++d) ;
3857 if (!warned && ckWARN(WARN_SYNTAX)) {
3858 for (; !isSPACE(*d) && len; --len, ++d) {
3861 "Possible attempt to separate words with commas");
3864 else if (*d == '#') {
3866 "Possible attempt to put comments in qw() list");
3872 for (; !isSPACE(*d) && len; --len, ++d) ;
3874 words = append_elem(OP_LIST, words,
3875 newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
3879 PL_nextval[PL_nexttoke].opval = words;
3884 SvREFCNT_dec(PL_lex_stuff);
3885 PL_lex_stuff = Nullsv;
3892 missingterm((char*)0);
3893 yylval.ival = OP_STRINGIFY;
3894 if (SvIVX(PL_lex_stuff) == '\'')
3895 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3896 TERM(sublex_start());
3899 s = scan_pat(s,OP_QR);
3900 TERM(sublex_start());
3905 missingterm((char*)0);
3906 yylval.ival = OP_BACKTICK;
3908 TERM(sublex_start());
3914 *PL_tokenbuf = '\0';
3915 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3916 if (isIDFIRST_lazy(PL_tokenbuf))
3917 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3919 yyerror("<> should be quotes");
3926 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3930 LOP(OP_RENAME,XTERM);
3939 LOP(OP_RINDEX,XTERM);
3962 LOP(OP_REVERSE,XTERM);
3973 TERM(sublex_start());
3975 TOKEN(1); /* force error */
3984 LOP(OP_SELECT,XTERM);
3990 LOP(OP_SEMCTL,XTERM);
3993 LOP(OP_SEMGET,XTERM);
3996 LOP(OP_SEMOP,XTERM);
4002 LOP(OP_SETPGRP,XTERM);
4004 case KEY_setpriority:
4005 LOP(OP_SETPRIORITY,XTERM);
4007 case KEY_sethostent:
4013 case KEY_setservent:
4016 case KEY_setprotoent:
4026 LOP(OP_SEEKDIR,XTERM);
4028 case KEY_setsockopt:
4029 LOP(OP_SSOCKOPT,XTERM);
4035 LOP(OP_SHMCTL,XTERM);
4038 LOP(OP_SHMGET,XTERM);
4041 LOP(OP_SHMREAD,XTERM);
4044 LOP(OP_SHMWRITE,XTERM);
4047 LOP(OP_SHUTDOWN,XTERM);
4056 LOP(OP_SOCKET,XTERM);
4058 case KEY_socketpair:
4059 LOP(OP_SOCKPAIR,XTERM);
4062 checkcomma(s,PL_tokenbuf,"subroutine name");
4064 if (*s == ';' || *s == ')') /* probably a close */
4065 croak("sort is now a reserved word");
4067 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4071 LOP(OP_SPLIT,XTERM);
4074 LOP(OP_SPRINTF,XTERM);
4077 LOP(OP_SPLICE,XTERM);
4093 LOP(OP_SUBSTR,XTERM);
4100 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4101 char tmpbuf[sizeof PL_tokenbuf];
4103 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4104 if (strchr(tmpbuf, ':'))
4105 sv_setpv(PL_subname, tmpbuf);
4107 sv_setsv(PL_subname,PL_curstname);
4108 sv_catpvn(PL_subname,"::",2);
4109 sv_catpvn(PL_subname,tmpbuf,len);
4111 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4115 PL_expect = XTERMBLOCK;
4116 sv_setpv(PL_subname,"?");
4119 if (tmp == KEY_format) {
4122 PL_lex_formbrack = PL_lex_brackets + 1;
4126 /* Look for a prototype */
4133 SvREFCNT_dec(PL_lex_stuff);
4134 PL_lex_stuff = Nullsv;
4135 croak("Prototype not terminated");
4138 d = SvPVX(PL_lex_stuff);
4140 for (p = d; *p; ++p) {
4145 SvCUR(PL_lex_stuff) = tmp;
4148 PL_nextval[1] = PL_nextval[0];
4149 PL_nexttype[1] = PL_nexttype[0];
4150 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4151 PL_nexttype[0] = THING;
4152 if (PL_nexttoke == 1) {
4153 PL_lex_defer = PL_lex_state;
4154 PL_lex_expect = PL_expect;
4155 PL_lex_state = LEX_KNOWNEXT;
4157 PL_lex_stuff = Nullsv;
4160 if (*SvPV(PL_subname,n_a) == '?') {
4161 sv_setpv(PL_subname,"__ANON__");
4168 LOP(OP_SYSTEM,XREF);
4171 LOP(OP_SYMLINK,XTERM);
4174 LOP(OP_SYSCALL,XTERM);
4177 LOP(OP_SYSOPEN,XTERM);
4180 LOP(OP_SYSSEEK,XTERM);
4183 LOP(OP_SYSREAD,XTERM);
4186 LOP(OP_SYSWRITE,XTERM);
4190 TERM(sublex_start());
4211 LOP(OP_TRUNCATE,XTERM);
4223 yylval.ival = PL_curcop->cop_line;
4227 yylval.ival = PL_curcop->cop_line;
4231 LOP(OP_UNLINK,XTERM);
4237 LOP(OP_UNPACK,XTERM);
4240 LOP(OP_UTIME,XTERM);
4243 if (ckWARN(WARN_OCTAL)) {
4244 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4245 if (*d != '0' && isDIGIT(*d))
4246 yywarn("umask: argument is missing initial 0");
4251 LOP(OP_UNSHIFT,XTERM);
4254 if (PL_expect != XSTATE)
4255 yyerror("\"use\" not allowed in expression");
4258 s = force_version(s);
4259 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4260 PL_nextval[PL_nexttoke].opval = Nullop;
4265 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4266 s = force_version(s);
4279 yylval.ival = PL_curcop->cop_line;
4283 PL_hints |= HINT_BLOCK_SCOPE;
4290 LOP(OP_WAITPID,XTERM);
4298 static char ctl_l[2];
4300 if (ctl_l[0] == '\0')
4301 ctl_l[0] = toCTRL('L');
4302 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4305 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4310 if (PL_expect == XOPERATOR)
4316 yylval.ival = OP_XOR;
4321 TERM(sublex_start());
4327 keyword(register char *d, I32 len)
4332 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4333 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4334 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4335 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4336 if (strEQ(d,"__END__")) return KEY___END__;
4340 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4345 if (strEQ(d,"and")) return -KEY_and;
4346 if (strEQ(d,"abs")) return -KEY_abs;
4349 if (strEQ(d,"alarm")) return -KEY_alarm;
4350 if (strEQ(d,"atan2")) return -KEY_atan2;
4353 if (strEQ(d,"accept")) return -KEY_accept;
4358 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4361 if (strEQ(d,"bless")) return -KEY_bless;
4362 if (strEQ(d,"bind")) return -KEY_bind;
4363 if (strEQ(d,"binmode")) return -KEY_binmode;
4366 if (strEQ(d,"CORE")) return -KEY_CORE;
4371 if (strEQ(d,"cmp")) return -KEY_cmp;
4372 if (strEQ(d,"chr")) return -KEY_chr;
4373 if (strEQ(d,"cos")) return -KEY_cos;
4376 if (strEQ(d,"chop")) return KEY_chop;
4379 if (strEQ(d,"close")) return -KEY_close;
4380 if (strEQ(d,"chdir")) return -KEY_chdir;
4381 if (strEQ(d,"chomp")) return KEY_chomp;
4382 if (strEQ(d,"chmod")) return -KEY_chmod;
4383 if (strEQ(d,"chown")) return -KEY_chown;
4384 if (strEQ(d,"crypt")) return -KEY_crypt;
4387 if (strEQ(d,"chroot")) return -KEY_chroot;
4388 if (strEQ(d,"caller")) return -KEY_caller;
4391 if (strEQ(d,"connect")) return -KEY_connect;
4394 if (strEQ(d,"closedir")) return -KEY_closedir;
4395 if (strEQ(d,"continue")) return -KEY_continue;
4400 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4405 if (strEQ(d,"do")) return KEY_do;
4408 if (strEQ(d,"die")) return -KEY_die;
4411 if (strEQ(d,"dump")) return -KEY_dump;
4414 if (strEQ(d,"delete")) return KEY_delete;
4417 if (strEQ(d,"defined")) return KEY_defined;
4418 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4421 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4426 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4427 if (strEQ(d,"END")) return KEY_END;
4432 if (strEQ(d,"eq")) return -KEY_eq;
4435 if (strEQ(d,"eof")) return -KEY_eof;
4436 if (strEQ(d,"exp")) return -KEY_exp;
4439 if (strEQ(d,"else")) return KEY_else;
4440 if (strEQ(d,"exit")) return -KEY_exit;
4441 if (strEQ(d,"eval")) return KEY_eval;
4442 if (strEQ(d,"exec")) return -KEY_exec;
4443 if (strEQ(d,"each")) return KEY_each;
4446 if (strEQ(d,"elsif")) return KEY_elsif;
4449 if (strEQ(d,"exists")) return KEY_exists;
4450 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4453 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4454 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4457 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4460 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4461 if (strEQ(d,"endservent")) return -KEY_endservent;
4464 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4471 if (strEQ(d,"for")) return KEY_for;
4474 if (strEQ(d,"fork")) return -KEY_fork;
4477 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4478 if (strEQ(d,"flock")) return -KEY_flock;
4481 if (strEQ(d,"format")) return KEY_format;
4482 if (strEQ(d,"fileno")) return -KEY_fileno;
4485 if (strEQ(d,"foreach")) return KEY_foreach;
4488 if (strEQ(d,"formline")) return -KEY_formline;
4494 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4495 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4499 if (strnEQ(d,"get",3)) {
4504 if (strEQ(d,"ppid")) return -KEY_getppid;
4505 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4508 if (strEQ(d,"pwent")) return -KEY_getpwent;
4509 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4510 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4513 if (strEQ(d,"peername")) return -KEY_getpeername;
4514 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4515 if (strEQ(d,"priority")) return -KEY_getpriority;
4518 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4521 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4525 else if (*d == 'h') {
4526 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4527 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4528 if (strEQ(d,"hostent")) return -KEY_gethostent;
4530 else if (*d == 'n') {
4531 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4532 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4533 if (strEQ(d,"netent")) return -KEY_getnetent;
4535 else if (*d == 's') {
4536 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4537 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4538 if (strEQ(d,"servent")) return -KEY_getservent;
4539 if (strEQ(d,"sockname")) return -KEY_getsockname;
4540 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4542 else if (*d == 'g') {
4543 if (strEQ(d,"grent")) return -KEY_getgrent;
4544 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4545 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4547 else if (*d == 'l') {
4548 if (strEQ(d,"login")) return -KEY_getlogin;
4550 else if (strEQ(d,"c")) return -KEY_getc;
4555 if (strEQ(d,"gt")) return -KEY_gt;
4556 if (strEQ(d,"ge")) return -KEY_ge;
4559 if (strEQ(d,"grep")) return KEY_grep;
4560 if (strEQ(d,"goto")) return KEY_goto;
4561 if (strEQ(d,"glob")) return KEY_glob;
4564 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4569 if (strEQ(d,"hex")) return -KEY_hex;
4572 if (strEQ(d,"INIT")) return KEY_INIT;
4577 if (strEQ(d,"if")) return KEY_if;
4580 if (strEQ(d,"int")) return -KEY_int;
4583 if (strEQ(d,"index")) return -KEY_index;
4584 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4589 if (strEQ(d,"join")) return -KEY_join;
4593 if (strEQ(d,"keys")) return KEY_keys;
4594 if (strEQ(d,"kill")) return -KEY_kill;
4599 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4600 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4606 if (strEQ(d,"lt")) return -KEY_lt;
4607 if (strEQ(d,"le")) return -KEY_le;
4608 if (strEQ(d,"lc")) return -KEY_lc;
4611 if (strEQ(d,"log")) return -KEY_log;
4614 if (strEQ(d,"last")) return KEY_last;
4615 if (strEQ(d,"link")) return -KEY_link;
4616 if (strEQ(d,"lock")) return -KEY_lock;
4619 if (strEQ(d,"local")) return KEY_local;
4620 if (strEQ(d,"lstat")) return -KEY_lstat;
4623 if (strEQ(d,"length")) return -KEY_length;
4624 if (strEQ(d,"listen")) return -KEY_listen;
4627 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4630 if (strEQ(d,"localtime")) return -KEY_localtime;
4636 case 1: return KEY_m;
4638 if (strEQ(d,"my")) return KEY_my;
4641 if (strEQ(d,"map")) return KEY_map;
4644 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4647 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4648 if (strEQ(d,"msgget")) return -KEY_msgget;
4649 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4650 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4655 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4658 if (strEQ(d,"next")) return KEY_next;
4659 if (strEQ(d,"ne")) return -KEY_ne;
4660 if (strEQ(d,"not")) return -KEY_not;
4661 if (strEQ(d,"no")) return KEY_no;
4666 if (strEQ(d,"or")) return -KEY_or;
4669 if (strEQ(d,"ord")) return -KEY_ord;
4670 if (strEQ(d,"oct")) return -KEY_oct;
4671 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4675 if (strEQ(d,"open")) return -KEY_open;
4678 if (strEQ(d,"opendir")) return -KEY_opendir;
4685 if (strEQ(d,"pop")) return KEY_pop;
4686 if (strEQ(d,"pos")) return KEY_pos;
4689 if (strEQ(d,"push")) return KEY_push;
4690 if (strEQ(d,"pack")) return -KEY_pack;
4691 if (strEQ(d,"pipe")) return -KEY_pipe;
4694 if (strEQ(d,"print")) return KEY_print;
4697 if (strEQ(d,"printf")) return KEY_printf;
4700 if (strEQ(d,"package")) return KEY_package;
4703 if (strEQ(d,"prototype")) return KEY_prototype;
4708 if (strEQ(d,"q")) return KEY_q;
4709 if (strEQ(d,"qr")) return KEY_qr;
4710 if (strEQ(d,"qq")) return KEY_qq;
4711 if (strEQ(d,"qw")) return KEY_qw;
4712 if (strEQ(d,"qx")) return KEY_qx;
4714 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4719 if (strEQ(d,"ref")) return -KEY_ref;
4722 if (strEQ(d,"read")) return -KEY_read;
4723 if (strEQ(d,"rand")) return -KEY_rand;
4724 if (strEQ(d,"recv")) return -KEY_recv;
4725 if (strEQ(d,"redo")) return KEY_redo;
4728 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4729 if (strEQ(d,"reset")) return -KEY_reset;
4732 if (strEQ(d,"return")) return KEY_return;
4733 if (strEQ(d,"rename")) return -KEY_rename;
4734 if (strEQ(d,"rindex")) return -KEY_rindex;
4737 if (strEQ(d,"require")) return -KEY_require;
4738 if (strEQ(d,"reverse")) return -KEY_reverse;
4739 if (strEQ(d,"readdir")) return -KEY_readdir;
4742 if (strEQ(d,"readlink")) return -KEY_readlink;
4743 if (strEQ(d,"readline")) return -KEY_readline;
4744 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4747 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4753 case 0: return KEY_s;
4755 if (strEQ(d,"scalar")) return KEY_scalar;
4760 if (strEQ(d,"seek")) return -KEY_seek;
4761 if (strEQ(d,"send")) return -KEY_send;
4764 if (strEQ(d,"semop")) return -KEY_semop;
4767 if (strEQ(d,"select")) return -KEY_select;
4768 if (strEQ(d,"semctl")) return -KEY_semctl;
4769 if (strEQ(d,"semget")) return -KEY_semget;
4772 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4773 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4776 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4777 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4780 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4783 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4784 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4785 if (strEQ(d,"setservent")) return -KEY_setservent;
4788 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4789 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4796 if (strEQ(d,"shift")) return KEY_shift;
4799 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4800 if (strEQ(d,"shmget")) return -KEY_shmget;
4803 if (strEQ(d,"shmread")) return -KEY_shmread;
4806 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4807 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4812 if (strEQ(d,"sin")) return -KEY_sin;
4815 if (strEQ(d,"sleep")) return -KEY_sleep;
4818 if (strEQ(d,"sort")) return KEY_sort;
4819 if (strEQ(d,"socket")) return -KEY_socket;
4820 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4823 if (strEQ(d,"split")) return KEY_split;
4824 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4825 if (strEQ(d,"splice")) return KEY_splice;
4828 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4831 if (strEQ(d,"srand")) return -KEY_srand;
4834 if (strEQ(d,"stat")) return -KEY_stat;
4835 if (strEQ(d,"study")) return KEY_study;
4838 if (strEQ(d,"substr")) return -KEY_substr;
4839 if (strEQ(d,"sub")) return KEY_sub;
4844 if (strEQ(d,"system")) return -KEY_system;
4847 if (strEQ(d,"symlink")) return -KEY_symlink;
4848 if (strEQ(d,"syscall")) return -KEY_syscall;
4849 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4850 if (strEQ(d,"sysread")) return -KEY_sysread;
4851 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4854 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4863 if (strEQ(d,"tr")) return KEY_tr;
4866 if (strEQ(d,"tie")) return KEY_tie;
4869 if (strEQ(d,"tell")) return -KEY_tell;
4870 if (strEQ(d,"tied")) return KEY_tied;
4871 if (strEQ(d,"time")) return -KEY_time;
4874 if (strEQ(d,"times")) return -KEY_times;
4877 if (strEQ(d,"telldir")) return -KEY_telldir;
4880 if (strEQ(d,"truncate")) return -KEY_truncate;
4887 if (strEQ(d,"uc")) return -KEY_uc;
4890 if (strEQ(d,"use")) return KEY_use;
4893 if (strEQ(d,"undef")) return KEY_undef;
4894 if (strEQ(d,"until")) return KEY_until;
4895 if (strEQ(d,"untie")) return KEY_untie;
4896 if (strEQ(d,"utime")) return -KEY_utime;
4897 if (strEQ(d,"umask")) return -KEY_umask;
4900 if (strEQ(d,"unless")) return KEY_unless;
4901 if (strEQ(d,"unpack")) return -KEY_unpack;
4902 if (strEQ(d,"unlink")) return -KEY_unlink;
4905 if (strEQ(d,"unshift")) return KEY_unshift;
4906 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4911 if (strEQ(d,"values")) return -KEY_values;
4912 if (strEQ(d,"vec")) return -KEY_vec;
4917 if (strEQ(d,"warn")) return -KEY_warn;
4918 if (strEQ(d,"wait")) return -KEY_wait;
4921 if (strEQ(d,"while")) return KEY_while;
4922 if (strEQ(d,"write")) return -KEY_write;
4925 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4928 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4933 if (len == 1) return -KEY_x;
4934 if (strEQ(d,"xor")) return -KEY_xor;
4937 if (len == 1) return KEY_y;
4946 checkcomma(register char *s, char *name, char *what)
4950 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4951 dTHR; /* only for ckWARN */
4952 if (ckWARN(WARN_SYNTAX)) {
4954 for (w = s+2; *w && level; w++) {
4961 for (; *w && isSPACE(*w); w++) ;
4962 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4963 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4966 while (s < PL_bufend && isSPACE(*s))
4970 while (s < PL_bufend && isSPACE(*s))
4972 if (isIDFIRST_lazy(s)) {
4974 while (isALNUM_lazy(s))
4976 while (s < PL_bufend && isSPACE(*s))
4981 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4985 croak("No comma allowed after %s", what);
4991 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4994 HV *table = GvHV(PL_hintgv); /* ^H */
4997 bool oldcatch = CATCH_GET;
5002 yyerror("%^H is not defined");
5005 cvp = hv_fetch(table, key, strlen(key), FALSE);
5006 if (!cvp || !SvOK(*cvp)) {
5008 sprintf(buf,"$^H{%s} is not defined", key);
5012 sv_2mortal(sv); /* Parent created it permanently */
5015 pv = sv_2mortal(newSVpvn(s, len));
5017 typesv = sv_2mortal(newSVpv(type, 0));
5019 typesv = &PL_sv_undef;
5021 Zero(&myop, 1, BINOP);
5022 myop.op_last = (OP *) &myop;
5023 myop.op_next = Nullop;
5024 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
5026 PUSHSTACKi(PERLSI_OVERLOAD);
5029 PL_op = (OP *) &myop;
5030 if (PERLDB_SUB && PL_curstash != PL_debstash)
5031 PL_op->op_private |= OPpENTERSUB_DB;
5042 if (PL_op = pp_entersub(ARGS))
5049 CATCH_SET(oldcatch);
5054 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5057 return SvREFCNT_inc(res);
5061 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5063 register char *d = dest;
5064 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5067 croak(ident_too_long);
5068 if (isALNUM(*s)) /* UTF handled below */
5070 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5075 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5079 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5080 char *t = s + UTF8SKIP(s);
5081 while (*t & 0x80 && is_utf8_mark((U8*)t))
5083 if (d + (t - s) > e)
5084 croak(ident_too_long);
5085 Copy(s, d, t - s, char);
5098 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5105 if (PL_lex_brackets == 0)
5106 PL_lex_fakebrack = 0;
5110 e = d + destlen - 3; /* two-character token, ending NUL */
5112 while (isDIGIT(*s)) {
5114 croak(ident_too_long);
5121 croak(ident_too_long);
5122 if (isALNUM(*s)) /* UTF handled below */
5124 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5129 else if (*s == ':' && s[1] == ':') {
5133 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5134 char *t = s + UTF8SKIP(s);
5135 while (*t & 0x80 && is_utf8_mark((U8*)t))
5137 if (d + (t - s) > e)
5138 croak(ident_too_long);
5139 Copy(s, d, t - s, char);
5150 if (PL_lex_state != LEX_NORMAL)
5151 PL_lex_state = LEX_INTERPENDMAYBE;
5154 if (*s == '$' && s[1] &&
5155 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5168 if (*d == '^' && *s && isCONTROLVAR(*s)) {
5173 if (isSPACE(s[-1])) {
5176 if (ch != ' ' && ch != '\t') {
5182 if (isIDFIRST_lazy(d)) {
5186 while (e < send && isALNUM_lazy(e) || *e == ':') {
5188 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5191 Copy(s, d, e - s, char);
5196 while ((isALNUM(*s) || *s == ':') && d < e)
5199 croak(ident_too_long);
5202 while (s < send && (*s == ' ' || *s == '\t')) s++;
5203 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5204 dTHR; /* only for ckWARN */
5205 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5206 char *brack = *s == '[' ? "[...]" : "{...}";
5207 warner(WARN_AMBIGUOUS,
5208 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5209 funny, dest, brack, funny, dest, brack);
5211 PL_lex_fakebrack = PL_lex_brackets+1;
5213 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5217 /* Handle extended ${^Foo} variables
5218 * 1999-02-27 mjd-perl-patch@plover.com */
5219 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5223 while (isALNUM(*s) && d < e) {
5227 croak(ident_too_long);
5232 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5233 PL_lex_state = LEX_INTERPEND;
5236 if (PL_lex_state == LEX_NORMAL) {
5237 dTHR; /* only for ckWARN */
5238 if (ckWARN(WARN_AMBIGUOUS) &&
5239 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5241 warner(WARN_AMBIGUOUS,
5242 "Ambiguous use of %c{%s} resolved to %c%s",
5243 funny, dest, funny, dest);
5248 s = bracket; /* let the parser handle it */
5252 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5253 PL_lex_state = LEX_INTERPEND;
5257 void pmflag(U16 *pmfl, int ch)
5262 *pmfl |= PMf_GLOBAL;
5264 *pmfl |= PMf_CONTINUE;
5268 *pmfl |= PMf_MULTILINE;
5270 *pmfl |= PMf_SINGLELINE;
5272 *pmfl |= PMf_EXTENDED;
5276 scan_pat(char *start, I32 type)
5281 s = scan_str(start);
5284 SvREFCNT_dec(PL_lex_stuff);
5285 PL_lex_stuff = Nullsv;
5286 croak("Search pattern not terminated");
5289 pm = (PMOP*)newPMOP(type, 0);
5290 if (PL_multi_open == '?')
5291 pm->op_pmflags |= PMf_ONCE;
5293 while (*s && strchr("iomsx", *s))
5294 pmflag(&pm->op_pmflags,*s++);
5297 while (*s && strchr("iogcmsx", *s))
5298 pmflag(&pm->op_pmflags,*s++);
5300 pm->op_pmpermflags = pm->op_pmflags;
5302 PL_lex_op = (OP*)pm;
5303 yylval.ival = OP_MATCH;
5308 scan_subst(char *start)
5315 yylval.ival = OP_NULL;
5317 s = scan_str(start);
5321 SvREFCNT_dec(PL_lex_stuff);
5322 PL_lex_stuff = Nullsv;
5323 croak("Substitution pattern not terminated");
5326 if (s[-1] == PL_multi_open)
5329 first_start = PL_multi_start;
5333 SvREFCNT_dec(PL_lex_stuff);
5334 PL_lex_stuff = Nullsv;
5336 SvREFCNT_dec(PL_lex_repl);
5337 PL_lex_repl = Nullsv;
5338 croak("Substitution replacement not terminated");
5340 PL_multi_start = first_start; /* so whole substitution is taken together */
5342 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5348 else if (strchr("iogcmsx", *s))
5349 pmflag(&pm->op_pmflags,*s++);
5356 PL_sublex_info.super_bufptr = s;
5357 PL_sublex_info.super_bufend = PL_bufend;
5359 pm->op_pmflags |= PMf_EVAL;
5360 repl = newSVpvn("",0);
5362 sv_catpv(repl, es ? "eval " : "do ");
5363 sv_catpvn(repl, "{ ", 2);
5364 sv_catsv(repl, PL_lex_repl);
5365 sv_catpvn(repl, " };", 2);
5366 SvCOMPILED_on(repl);
5367 SvREFCNT_dec(PL_lex_repl);
5371 pm->op_pmpermflags = pm->op_pmflags;
5372 PL_lex_op = (OP*)pm;
5373 yylval.ival = OP_SUBST;
5378 scan_trans(char *start)
5389 yylval.ival = OP_NULL;
5391 s = scan_str(start);
5394 SvREFCNT_dec(PL_lex_stuff);
5395 PL_lex_stuff = Nullsv;
5396 croak("Transliteration pattern not terminated");
5398 if (s[-1] == PL_multi_open)
5404 SvREFCNT_dec(PL_lex_stuff);
5405 PL_lex_stuff = Nullsv;
5407 SvREFCNT_dec(PL_lex_repl);
5408 PL_lex_repl = Nullsv;
5409 croak("Transliteration replacement not terminated");
5413 o = newSVOP(OP_TRANS, 0, 0);
5414 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5417 New(803,tbl,256,short);
5418 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5422 complement = del = squash = 0;
5423 while (strchr("cdsCU", *s)) {
5425 complement = OPpTRANS_COMPLEMENT;
5427 del = OPpTRANS_DELETE;
5429 squash = OPpTRANS_SQUASH;
5434 utf8 &= ~OPpTRANS_FROM_UTF;
5436 utf8 |= OPpTRANS_FROM_UTF;
5440 utf8 &= ~OPpTRANS_TO_UTF;
5442 utf8 |= OPpTRANS_TO_UTF;
5445 croak("Too many /C and /U options");
5450 o->op_private = del|squash|complement|utf8;
5453 yylval.ival = OP_TRANS;
5458 scan_heredoc(register char *s)
5462 I32 op_type = OP_SCALAR;
5469 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5473 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5476 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5477 if (*peek && strchr("`'\"",*peek)) {
5480 s = delimcpy(d, e, s, PL_bufend, term, &len);
5490 if (!isALNUM_lazy(s))
5491 deprecate("bare << to mean <<\"\"");
5492 for (; isALNUM_lazy(s); s++) {
5497 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5498 croak("Delimiter for here document is too long");
5501 len = d - PL_tokenbuf;
5502 #ifndef PERL_STRICT_CR
5503 d = strchr(s, '\r');
5507 while (s < PL_bufend) {
5513 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5522 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5527 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5528 herewas = newSVpvn(s,PL_bufend-s);
5530 s--, herewas = newSVpvn(s,d-s);
5531 s += SvCUR(herewas);
5533 tmpstr = NEWSV(87,79);
5534 sv_upgrade(tmpstr, SVt_PVIV);
5539 else if (term == '`') {
5540 op_type = OP_BACKTICK;
5541 SvIVX(tmpstr) = '\\';
5545 PL_multi_start = PL_curcop->cop_line;
5546 PL_multi_open = PL_multi_close = '<';
5547 term = *PL_tokenbuf;
5548 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5549 char *bufptr = PL_sublex_info.super_bufptr;
5550 char *bufend = PL_sublex_info.super_bufend;
5551 char *olds = s - SvCUR(herewas);
5552 s = strchr(bufptr, '\n');
5556 while (s < bufend &&
5557 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5559 PL_curcop->cop_line++;
5562 PL_curcop->cop_line = PL_multi_start;
5563 missingterm(PL_tokenbuf);
5565 sv_setpvn(herewas,bufptr,d-bufptr+1);
5566 sv_setpvn(tmpstr,d+1,s-d);
5568 sv_catpvn(herewas,s,bufend-s);
5569 (void)strcpy(bufptr,SvPVX(herewas));
5576 while (s < PL_bufend &&
5577 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5579 PL_curcop->cop_line++;
5581 if (s >= PL_bufend) {
5582 PL_curcop->cop_line = PL_multi_start;
5583 missingterm(PL_tokenbuf);
5585 sv_setpvn(tmpstr,d+1,s-d);
5587 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5589 sv_catpvn(herewas,s,PL_bufend-s);
5590 sv_setsv(PL_linestr,herewas);
5591 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5592 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5595 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5596 while (s >= PL_bufend) { /* multiple line string? */
5598 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5599 PL_curcop->cop_line = PL_multi_start;
5600 missingterm(PL_tokenbuf);
5602 PL_curcop->cop_line++;
5603 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5604 #ifndef PERL_STRICT_CR
5605 if (PL_bufend - PL_linestart >= 2) {
5606 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5607 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5609 PL_bufend[-2] = '\n';
5611 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5613 else if (PL_bufend[-1] == '\r')
5614 PL_bufend[-1] = '\n';
5616 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5617 PL_bufend[-1] = '\n';
5619 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5620 SV *sv = NEWSV(88,0);
5622 sv_upgrade(sv, SVt_PVMG);
5623 sv_setsv(sv,PL_linestr);
5624 av_store(GvAV(PL_curcop->cop_filegv),
5625 (I32)PL_curcop->cop_line,sv);
5627 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5630 sv_catsv(PL_linestr,herewas);
5631 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5635 sv_catsv(tmpstr,PL_linestr);
5640 PL_multi_end = PL_curcop->cop_line;
5641 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5642 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5643 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5645 SvREFCNT_dec(herewas);
5646 PL_lex_stuff = tmpstr;
5647 yylval.ival = op_type;
5652 takes: current position in input buffer
5653 returns: new position in input buffer
5654 side-effects: yylval and lex_op are set.
5659 <FH> read from filehandle
5660 <pkg::FH> read from package qualified filehandle
5661 <pkg'FH> read from package qualified filehandle
5662 <$fh> read from filehandle in $fh
5668 scan_inputsymbol(char *start)
5670 register char *s = start; /* current position in buffer */
5676 d = PL_tokenbuf; /* start of temp holding space */
5677 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5678 end = strchr(s, '\n');
5681 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
5683 /* die if we didn't have space for the contents of the <>,
5684 or if it didn't end, or if we see a newline
5687 if (len >= sizeof PL_tokenbuf)
5688 croak("Excessively long <> operator");
5690 croak("Unterminated <> operator");
5695 Remember, only scalar variables are interpreted as filehandles by
5696 this code. Anything more complex (e.g., <$fh{$num}>) will be
5697 treated as a glob() call.
5698 This code makes use of the fact that except for the $ at the front,
5699 a scalar variable and a filehandle look the same.
5701 if (*d == '$' && d[1]) d++;
5703 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5704 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5707 /* If we've tried to read what we allow filehandles to look like, and
5708 there's still text left, then it must be a glob() and not a getline.
5709 Use scan_str to pull out the stuff between the <> and treat it
5710 as nothing more than a string.
5713 if (d - PL_tokenbuf != len) {
5714 yylval.ival = OP_GLOB;
5716 s = scan_str(start);
5718 croak("Glob not terminated");
5722 /* we're in a filehandle read situation */
5725 /* turn <> into <ARGV> */
5727 (void)strcpy(d,"ARGV");
5729 /* if <$fh>, create the ops to turn the variable into a
5735 /* try to find it in the pad for this block, otherwise find
5736 add symbol table ops
5738 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5739 OP *o = newOP(OP_PADSV, 0);
5741 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5744 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5745 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5746 newUNOP(OP_RV2SV, 0,
5747 newGVOP(OP_GV, 0, gv)));
5749 PL_lex_op->op_flags |= OPf_SPECIAL;
5750 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5751 yylval.ival = OP_NULL;
5754 /* If it's none of the above, it must be a literal filehandle
5755 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5757 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5758 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5759 yylval.ival = OP_NULL;
5768 takes: start position in buffer
5769 returns: position to continue reading from buffer
5770 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5771 updates the read buffer.
5773 This subroutine pulls a string out of the input. It is called for:
5774 q single quotes q(literal text)
5775 ' single quotes 'literal text'
5776 qq double quotes qq(interpolate $here please)
5777 " double quotes "interpolate $here please"
5778 qx backticks qx(/bin/ls -l)
5779 ` backticks `/bin/ls -l`
5780 qw quote words @EXPORT_OK = qw( func() $spam )
5781 m// regexp match m/this/
5782 s/// regexp substitute s/this/that/
5783 tr/// string transliterate tr/this/that/
5784 y/// string transliterate y/this/that/
5785 ($*@) sub prototypes sub foo ($)
5786 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5788 In most of these cases (all but <>, patterns and transliterate)
5789 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5790 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5791 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5794 It skips whitespace before the string starts, and treats the first
5795 character as the delimiter. If the delimiter is one of ([{< then
5796 the corresponding "close" character )]}> is used as the closing
5797 delimiter. It allows quoting of delimiters, and if the string has
5798 balanced delimiters ([{<>}]) it allows nesting.
5800 The lexer always reads these strings into lex_stuff, except in the
5801 case of the operators which take *two* arguments (s/// and tr///)
5802 when it checks to see if lex_stuff is full (presumably with the 1st
5803 arg to s or tr) and if so puts the string into lex_repl.
5808 scan_str(char *start)
5811 SV *sv; /* scalar value: string */
5812 char *tmps; /* temp string, used for delimiter matching */
5813 register char *s = start; /* current position in the buffer */
5814 register char term; /* terminating character */
5815 register char *to; /* current position in the sv's data */
5816 I32 brackets = 1; /* bracket nesting level */
5818 /* skip space before the delimiter */
5822 /* mark where we are, in case we need to report errors */
5825 /* after skipping whitespace, the next character is the terminator */
5827 /* mark where we are */
5828 PL_multi_start = PL_curcop->cop_line;
5829 PL_multi_open = term;
5831 /* find corresponding closing delimiter */
5832 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5834 PL_multi_close = term;
5836 /* create a new SV to hold the contents. 87 is leak category, I'm
5837 assuming. 79 is the SV's initial length. What a random number. */
5839 sv_upgrade(sv, SVt_PVIV);
5841 (void)SvPOK_only(sv); /* validate pointer */
5843 /* move past delimiter and try to read a complete string */
5846 /* extend sv if need be */
5847 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5848 /* set 'to' to the next character in the sv's string */
5849 to = SvPVX(sv)+SvCUR(sv);
5851 /* if open delimiter is the close delimiter read unbridle */
5852 if (PL_multi_open == PL_multi_close) {
5853 for (; s < PL_bufend; s++,to++) {
5854 /* embedded newlines increment the current line number */
5855 if (*s == '\n' && !PL_rsfp)
5856 PL_curcop->cop_line++;
5857 /* handle quoted delimiters */
5858 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5861 /* any other quotes are simply copied straight through */
5865 /* terminate when run out of buffer (the for() condition), or
5866 have found the terminator */
5867 else if (*s == term)
5873 /* if the terminator isn't the same as the start character (e.g.,
5874 matched brackets), we have to allow more in the quoting, and
5875 be prepared for nested brackets.
5878 /* read until we run out of string, or we find the terminator */
5879 for (; s < PL_bufend; s++,to++) {
5880 /* embedded newlines increment the line count */
5881 if (*s == '\n' && !PL_rsfp)
5882 PL_curcop->cop_line++;
5883 /* backslashes can escape the open or closing characters */
5884 if (*s == '\\' && s+1 < PL_bufend) {
5885 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5890 /* allow nested opens and closes */
5891 else if (*s == PL_multi_close && --brackets <= 0)
5893 else if (*s == PL_multi_open)
5898 /* terminate the copied string and update the sv's end-of-string */
5900 SvCUR_set(sv, to - SvPVX(sv));
5903 * this next chunk reads more into the buffer if we're not done yet
5906 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5908 #ifndef PERL_STRICT_CR
5909 if (to - SvPVX(sv) >= 2) {
5910 if ((to[-2] == '\r' && to[-1] == '\n') ||
5911 (to[-2] == '\n' && to[-1] == '\r'))
5915 SvCUR_set(sv, to - SvPVX(sv));
5917 else if (to[-1] == '\r')
5920 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5924 /* if we're out of file, or a read fails, bail and reset the current
5925 line marker so we can report where the unterminated string began
5928 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5930 PL_curcop->cop_line = PL_multi_start;
5933 /* we read a line, so increment our line counter */
5934 PL_curcop->cop_line++;
5936 /* update debugger info */
5937 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5938 SV *sv = NEWSV(88,0);
5940 sv_upgrade(sv, SVt_PVMG);
5941 sv_setsv(sv,PL_linestr);
5942 av_store(GvAV(PL_curcop->cop_filegv),
5943 (I32)PL_curcop->cop_line, sv);
5946 /* having changed the buffer, we must update PL_bufend */
5947 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5950 /* at this point, we have successfully read the delimited string */
5952 PL_multi_end = PL_curcop->cop_line;
5955 /* if we allocated too much space, give some back */
5956 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5957 SvLEN_set(sv, SvCUR(sv) + 1);
5958 Renew(SvPVX(sv), SvLEN(sv), char);
5961 /* decide whether this is the first or second quoted string we've read
5974 takes: pointer to position in buffer
5975 returns: pointer to new position in buffer
5976 side-effects: builds ops for the constant in yylval.op
5978 Read a number in any of the formats that Perl accepts:
5980 0(x[0-7A-F]+)|([0-7]+)|(b[01])
5981 [\d_]+(\.[\d_]*)?[Ee](\d+)
5983 Underbars (_) are allowed in decimal numbers. If -w is on,
5984 underbars before a decimal point must be at three digit intervals.
5986 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5989 If it reads a number without a decimal point or an exponent, it will
5990 try converting the number to an integer and see if it can do so
5991 without loss of precision.
5995 scan_num(char *start)
5997 register char *s = start; /* current position in buffer */
5998 register char *d; /* destination in temp buffer */
5999 register char *e; /* end of temp buffer */
6000 I32 tryiv; /* used to see if it can be an int */
6001 double value; /* number read, as a double */
6002 SV *sv; /* place to put the converted number */
6003 I32 floatit; /* boolean: int or float? */
6004 char *lastub = 0; /* position of last underbar */
6005 static char number_too_long[] = "Number too long";
6007 /* We use the first character to decide what type of number this is */
6011 croak("panic: scan_num");
6013 /* if it starts with a 0, it could be an octal number, a decimal in
6014 0.13 disguise, or a hexadecimal number, or a binary number.
6019 u holds the "number so far"
6020 shift the power of 2 of the base
6021 (hex == 4, octal == 3, binary == 1)
6022 overflowed was the number more than we can hold?
6024 Shift is used when we add a digit. It also serves as an "are
6025 we in octal/hex/binary?" indicator to disallow hex characters
6030 bool overflowed = FALSE;
6036 } else if (s[1] == 'b') {
6040 /* check for a decimal in disguise */
6041 else if (s[1] == '.')
6043 /* so it must be octal */
6048 /* read the rest of the number */
6050 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
6054 /* if we don't mention it, we're done */
6063 /* 8 and 9 are not octal */
6066 yyerror(form("Illegal octal digit '%c'", *s));
6069 yyerror(form("Illegal binary digit '%c'", *s));
6073 case '2': case '3': case '4':
6074 case '5': case '6': case '7':
6076 yyerror(form("Illegal binary digit '%c'", *s));
6080 b = *s++ & 15; /* ASCII digit -> value of digit */
6084 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6085 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6086 /* make sure they said 0x */
6091 /* Prepare to put the digit we have onto the end
6092 of the number so far. We check for overflows.
6096 n = u << shift; /* make room for the digit */
6097 if (!overflowed && (n >> shift) != u
6098 && !(PL_hints & HINT_NEW_BINARY)) {
6099 warn("Integer overflow in %s number",
6100 (shift == 4) ? "hex"
6101 : ((shift == 3) ? "octal" : "binary"));
6104 u = n | b; /* add the digit to the end */
6109 /* if we get here, we had success: make a scalar value from
6115 if ( PL_hints & HINT_NEW_BINARY)
6116 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6121 handle decimal numbers.
6122 we're also sent here when we read a 0 as the first digit
6124 case '1': case '2': case '3': case '4': case '5':
6125 case '6': case '7': case '8': case '9': case '.':
6128 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6131 /* read next group of digits and _ and copy into d */
6132 while (isDIGIT(*s) || *s == '_') {
6133 /* skip underscores, checking for misplaced ones
6137 dTHR; /* only for ckWARN */
6138 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6139 warner(WARN_SYNTAX, "Misplaced _ in number");
6143 /* check for end of fixed-length buffer */
6145 croak(number_too_long);
6146 /* if we're ok, copy the character */
6151 /* final misplaced underbar check */
6152 if (lastub && s - lastub != 3) {
6154 if (ckWARN(WARN_SYNTAX))
6155 warner(WARN_SYNTAX, "Misplaced _ in number");
6158 /* read a decimal portion if there is one. avoid
6159 3..5 being interpreted as the number 3. followed
6162 if (*s == '.' && s[1] != '.') {
6166 /* copy, ignoring underbars, until we run out of
6167 digits. Note: no misplaced underbar checks!
6169 for (; isDIGIT(*s) || *s == '_'; s++) {
6170 /* fixed length buffer check */
6172 croak(number_too_long);
6178 /* read exponent part, if present */
6179 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6183 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6184 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6186 /* allow positive or negative exponent */
6187 if (*s == '+' || *s == '-')
6190 /* read digits of exponent (no underbars :-) */
6191 while (isDIGIT(*s)) {
6193 croak(number_too_long);
6198 /* terminate the string */
6201 /* make an sv from the string */
6203 /* reset numeric locale in case we were earlier left in Swaziland */
6204 SET_NUMERIC_STANDARD();
6205 value = atof(PL_tokenbuf);
6208 See if we can make do with an integer value without loss of
6209 precision. We use I_V to cast to an int, because some
6210 compilers have issues. Then we try casting it back and see
6211 if it was the same. We only do this if we know we
6212 specifically read an integer.
6214 Note: if floatit is true, then we don't need to do the
6218 if (!floatit && (double)tryiv == value)
6219 sv_setiv(sv, tryiv);
6221 sv_setnv(sv, value);
6222 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6223 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6224 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6228 /* make the op for the constant and return */
6230 yylval.opval = newSVOP(OP_CONST, 0, sv);
6236 scan_formline(register char *s)
6241 SV *stuff = newSVpvn("",0);
6242 bool needargs = FALSE;
6245 if (*s == '.' || *s == '}') {
6247 #ifdef PERL_STRICT_CR
6248 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6250 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6252 if (*t == '\n' || t == PL_bufend)
6255 if (PL_in_eval && !PL_rsfp) {
6256 eol = strchr(s,'\n');
6261 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6263 for (t = s; t < eol; t++) {
6264 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6266 goto enough; /* ~~ must be first line in formline */
6268 if (*t == '@' || *t == '^')
6271 sv_catpvn(stuff, s, eol-s);
6275 s = filter_gets(PL_linestr, PL_rsfp, 0);
6276 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6277 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6280 yyerror("Format not terminated");
6290 PL_lex_state = LEX_NORMAL;
6291 PL_nextval[PL_nexttoke].ival = 0;
6295 PL_lex_state = LEX_FORMLINE;
6296 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6298 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6302 SvREFCNT_dec(stuff);
6303 PL_lex_formbrack = 0;
6314 PL_cshlen = strlen(PL_cshname);
6319 start_subparse(I32 is_format, U32 flags)
6322 I32 oldsavestack_ix = PL_savestack_ix;
6323 CV* outsidecv = PL_compcv;
6327 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6329 save_I32(&PL_subline);
6330 save_item(PL_subname);
6332 SAVESPTR(PL_curpad);
6333 SAVESPTR(PL_comppad);
6334 SAVESPTR(PL_comppad_name);
6335 SAVESPTR(PL_compcv);
6336 SAVEI32(PL_comppad_name_fill);
6337 SAVEI32(PL_min_intro_pending);
6338 SAVEI32(PL_max_intro_pending);
6339 SAVEI32(PL_pad_reset_pending);
6341 PL_compcv = (CV*)NEWSV(1104,0);
6342 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6343 CvFLAGS(PL_compcv) |= flags;
6345 PL_comppad = newAV();
6346 av_push(PL_comppad, Nullsv);
6347 PL_curpad = AvARRAY(PL_comppad);
6348 PL_comppad_name = newAV();
6349 PL_comppad_name_fill = 0;
6350 PL_min_intro_pending = 0;
6352 PL_subline = PL_curcop->cop_line;
6354 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6355 PL_curpad[0] = (SV*)newAV();
6356 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6357 #endif /* USE_THREADS */
6359 comppadlist = newAV();
6360 AvREAL_off(comppadlist);
6361 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6362 av_store(comppadlist, 1, (SV*)PL_comppad);
6364 CvPADLIST(PL_compcv) = comppadlist;
6365 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6367 CvOWNER(PL_compcv) = 0;
6368 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6369 MUTEX_INIT(CvMUTEXP(PL_compcv));
6370 #endif /* USE_THREADS */
6372 return oldsavestack_ix;
6391 char *context = NULL;
6395 if (!yychar || (yychar == ';' && !PL_rsfp))
6397 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6398 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6399 while (isSPACE(*PL_oldoldbufptr))
6401 context = PL_oldoldbufptr;
6402 contlen = PL_bufptr - PL_oldoldbufptr;
6404 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6405 PL_oldbufptr != PL_bufptr) {
6406 while (isSPACE(*PL_oldbufptr))
6408 context = PL_oldbufptr;
6409 contlen = PL_bufptr - PL_oldbufptr;
6411 else if (yychar > 255)
6412 where = "next token ???";
6413 else if ((yychar & 127) == 127) {
6414 if (PL_lex_state == LEX_NORMAL ||
6415 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6416 where = "at end of line";
6417 else if (PL_lex_inpat)
6418 where = "within pattern";
6420 where = "within string";
6423 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6425 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6426 else if (isPRINT_LC(yychar))
6427 sv_catpvf(where_sv, "%c", yychar);
6429 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6430 where = SvPVX(where_sv);
6432 msg = sv_2mortal(newSVpv(s, 0));
6433 sv_catpvf(msg, " at %_ line %ld, ",
6434 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6436 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6438 sv_catpvf(msg, "%s\n", where);
6439 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6441 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6442 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6447 else if (PL_in_eval)
6448 sv_catsv(ERRSV, msg);
6450 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6451 if (++PL_error_count >= 10)
6452 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6454 PL_in_my_stash = Nullhv;