3 * Copyright (c) 1991-1997, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It all comes from here, the stench and the peril." --Frodo
17 #define yychar PL_yychar
18 #define yylval PL_yylval
21 static void check_uni _((void));
22 static void force_next _((I32 type));
23 static char *force_version _((char *start));
24 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
25 static SV *tokeq _((SV *sv));
26 static char *scan_const _((char *start));
27 static char *scan_formline _((char *s));
28 static char *scan_heredoc _((char *s));
29 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
31 static char *scan_inputsymbol _((char *start));
32 static char *scan_pat _((char *start, I32 type));
33 static char *scan_str _((char *start));
34 static char *scan_subst _((char *start));
35 static char *scan_trans _((char *start));
36 static char *scan_word _((char *s, char *dest, STRLEN destlen,
37 int allow_package, STRLEN *slp));
38 static char *skipspace _((char *s));
39 static void checkcomma _((char *s, char *name, char *what));
40 static void force_ident _((char *s, int kind));
41 static void incline _((char *s));
42 static int intuit_method _((char *s, GV *gv));
43 static int intuit_more _((char *s));
44 static I32 lop _((I32 f, expectation x, char *s));
45 static void missingterm _((char *s));
46 static void no_op _((char *what, char *s));
47 static void set_csh _((void));
48 static I32 sublex_done _((void));
49 static I32 sublex_push _((void));
50 static I32 sublex_start _((void));
52 static int uni _((I32 f, char *s));
54 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
55 static void restore_rsfp _((void *f));
56 static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
57 static void restore_expect _((void *e));
58 static void restore_lex_expect _((void *e));
59 #endif /* PERL_OBJECT */
61 static char ident_too_long[] = "Identifier too long";
63 #define UTF (PL_hints & HINT_UTF8)
65 * Note: we try to be careful never to call the isXXX_utf8() functions
66 * unless we're pretty sure we've seen the beginning of a UTF-8 character
67 * (that is, the two high bits are set). Otherwise we risk loading in the
68 * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
70 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
72 : isIDFIRST_utf8((U8*)p))
73 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
75 : isALNUM_utf8((U8*)p))
77 /* The following are arranged oddly so that the guard on the switch statement
78 * can get by with a single comparison (if the compiler is smart enough).
81 /* #define LEX_NOTPARSING 11 is done in perl.h. */
84 #define LEX_INTERPNORMAL 9
85 #define LEX_INTERPCASEMOD 8
86 #define LEX_INTERPPUSH 7
87 #define LEX_INTERPSTART 6
88 #define LEX_INTERPEND 5
89 #define LEX_INTERPENDMAYBE 4
90 #define LEX_INTERPCONCAT 3
91 #define LEX_INTERPCONST 2
92 #define LEX_FORMLINE 1
93 #define LEX_KNOWNEXT 0
102 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
104 # include <unistd.h> /* Needed for execv() */
112 #ifdef USE_PURE_BISON
113 YYSTYPE* yylval_pointer = NULL;
114 int* yychar_pointer = NULL;
117 # define yylval (*yylval_pointer)
118 # define yychar (*yychar_pointer)
119 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
121 # define PERL_YYLEX_PARAM
124 #include "keywords.h"
129 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
131 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
132 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
133 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
134 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
135 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
136 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
137 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
138 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
139 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
140 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
141 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
142 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
143 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
144 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
145 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
146 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
147 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
148 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
149 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
150 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
152 /* This bit of chicanery makes a unary function followed by
153 * a parenthesis into a function with one argument, highest precedence.
155 #define UNI(f) return(yylval.ival = f, \
158 PL_last_uni = PL_oldbufptr, \
159 PL_last_lop_op = f, \
160 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
162 #define UNIBRACK(f) return(yylval.ival = f, \
164 PL_last_uni = PL_oldbufptr, \
165 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
167 /* grandfather return to old style */
168 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
173 if (*PL_bufptr == '=') {
175 if (toketype == ANDAND)
176 yylval.ival = OP_ANDASSIGN;
177 else if (toketype == OROR)
178 yylval.ival = OP_ORASSIGN;
185 no_op(char *what, char *s)
187 char *oldbp = PL_bufptr;
188 bool is_first = (PL_oldbufptr == PL_linestart);
191 yywarn(form("%s found where operator expected", what));
193 warn("\t(Missing semicolon on previous line?)\n");
194 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
196 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
197 if (t < PL_bufptr && isSPACE(*t))
198 warn("\t(Do you need to predeclare %.*s?)\n",
199 t - PL_oldoldbufptr, PL_oldoldbufptr);
203 warn("\t(Missing operator before end of line?)\n");
205 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
215 char *nl = strrchr(s,'\n');
221 iscntrl(PL_multi_close)
223 PL_multi_close < 32 || PL_multi_close == 127
227 tmpbuf[1] = toCTRL(PL_multi_close);
233 *tmpbuf = PL_multi_close;
237 q = strchr(s,'"') ? '\'' : '"';
238 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
245 if (ckWARN(WARN_DEPRECATED))
246 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
252 deprecate("comma-less variable list");
258 win32_textfilter(int idx, SV *sv, int maxlen)
260 I32 count = FILTER_READ(idx+1, sv, maxlen);
261 if (count > 0 && !maxlen)
262 win32_strip_return(sv);
270 utf16_textfilter(int idx, SV *sv, int maxlen)
272 I32 count = FILTER_READ(idx+1, sv, maxlen);
276 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
277 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
278 sv_usepvn(sv, (char*)tmps, tend - tmps);
285 utf16rev_textfilter(int idx, SV *sv, int maxlen)
287 I32 count = FILTER_READ(idx+1, sv, maxlen);
291 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
292 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
293 sv_usepvn(sv, (char*)tmps, tend - tmps);
308 SAVEI32(PL_lex_dojoin);
309 SAVEI32(PL_lex_brackets);
310 SAVEI32(PL_lex_fakebrack);
311 SAVEI32(PL_lex_casemods);
312 SAVEI32(PL_lex_starts);
313 SAVEI32(PL_lex_state);
314 SAVESPTR(PL_lex_inpat);
315 SAVEI32(PL_lex_inwhat);
316 SAVEI16(PL_curcop->cop_line);
319 SAVEPPTR(PL_oldbufptr);
320 SAVEPPTR(PL_oldoldbufptr);
321 SAVEPPTR(PL_linestart);
322 SAVESPTR(PL_linestr);
323 SAVEPPTR(PL_lex_brackstack);
324 SAVEPPTR(PL_lex_casestack);
325 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
326 SAVESPTR(PL_lex_stuff);
327 SAVEI32(PL_lex_defer);
328 SAVESPTR(PL_lex_repl);
329 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
330 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
332 PL_lex_state = LEX_NORMAL;
336 PL_lex_fakebrack = 0;
337 New(899, PL_lex_brackstack, 120, char);
338 New(899, PL_lex_casestack, 12, char);
339 SAVEFREEPV(PL_lex_brackstack);
340 SAVEFREEPV(PL_lex_casestack);
342 *PL_lex_casestack = '\0';
345 PL_lex_stuff = Nullsv;
346 PL_lex_repl = Nullsv;
350 if (SvREADONLY(PL_linestr))
351 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
352 s = SvPV(PL_linestr, len);
353 if (len && s[len-1] != ';') {
354 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
355 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
356 sv_catpvn(PL_linestr, "\n;", 2);
358 SvTEMP_off(PL_linestr);
359 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
360 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
362 PL_rs = newSVpv("\n", 1);
369 PL_doextract = FALSE;
373 restore_rsfp(void *f)
375 PerlIO *fp = (PerlIO*)f;
377 if (PL_rsfp == PerlIO_stdin())
378 PerlIO_clearerr(PL_rsfp);
379 else if (PL_rsfp && (PL_rsfp != fp))
380 PerlIO_close(PL_rsfp);
385 restore_expect(void *e)
387 /* a safe way to store a small integer in a pointer */
388 PL_expect = (expectation)((char *)e - PL_tokenbuf);
392 restore_lex_expect(void *e)
394 /* a safe way to store a small integer in a pointer */
395 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
407 PL_curcop->cop_line++;
410 while (*s == ' ' || *s == '\t') s++;
411 if (strnEQ(s, "line ", 5)) {
420 while (*s == ' ' || *s == '\t')
422 if (*s == '"' && (t = strchr(s+1, '"')))
426 return; /* false alarm */
427 for (t = s; !isSPACE(*t); t++) ;
432 PL_curcop->cop_filegv = gv_fetchfile(s);
434 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
436 PL_curcop->cop_line = atoi(n)-1;
440 skipspace(register char *s)
443 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
444 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
450 while (s < PL_bufend && isSPACE(*s)) {
451 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
454 if (s < PL_bufend && *s == '#') {
455 while (s < PL_bufend && *s != '\n')
459 if (PL_in_eval && !PL_rsfp) {
465 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
467 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
468 if (PL_minus_n || PL_minus_p) {
469 sv_setpv(PL_linestr,PL_minus_p ?
470 ";}continue{print or die qq(-p destination: $!\\n)" :
472 sv_catpv(PL_linestr,";}");
473 PL_minus_n = PL_minus_p = 0;
476 sv_setpv(PL_linestr,";");
477 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
478 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
479 if (PL_preprocess && !PL_in_eval)
480 (void)PerlProc_pclose(PL_rsfp);
481 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
482 PerlIO_clearerr(PL_rsfp);
484 (void)PerlIO_close(PL_rsfp);
488 PL_linestart = PL_bufptr = s + prevlen;
489 PL_bufend = s + SvCUR(PL_linestr);
492 if (PERLDB_LINE && PL_curstash != PL_debstash) {
493 SV *sv = NEWSV(85,0);
495 sv_upgrade(sv, SVt_PVMG);
496 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
497 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
508 if (PL_oldoldbufptr != PL_last_uni)
510 while (isSPACE(*PL_last_uni))
512 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
513 if ((t = strchr(s, '(')) && t < PL_bufptr)
517 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
524 #define UNI(f) return uni(f,s)
532 PL_last_uni = PL_oldbufptr;
543 #endif /* CRIPPLED_CC */
545 #define LOP(f,x) return lop(f,x,s)
548 lop(I32 f, expectation x, char *s)
555 PL_last_lop = PL_oldbufptr;
571 PL_nexttype[PL_nexttoke] = type;
573 if (PL_lex_state != LEX_KNOWNEXT) {
574 PL_lex_defer = PL_lex_state;
575 PL_lex_expect = PL_expect;
576 PL_lex_state = LEX_KNOWNEXT;
581 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
586 start = skipspace(start);
588 if (isIDFIRST_lazy(s) ||
589 (allow_pack && *s == ':') ||
590 (allow_initial_tick && *s == '\'') )
592 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
593 if (check_keyword && keyword(PL_tokenbuf, len))
595 if (token == METHOD) {
600 PL_expect = XOPERATOR;
605 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
606 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
613 force_ident(register char *s, int kind)
616 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
617 PL_nextval[PL_nexttoke].opval = o;
620 dTHR; /* just for in_eval */
621 o->op_private = OPpCONST_ENTERED;
622 /* XXX see note in pp_entereval() for why we forgo typo
623 warnings if the symbol must be introduced in an eval.
625 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
626 kind == '$' ? SVt_PV :
627 kind == '@' ? SVt_PVAV :
628 kind == '%' ? SVt_PVHV :
636 force_version(char *s)
638 OP *version = Nullop;
642 /* default VERSION number -- GBARR */
647 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
648 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
650 /* real VERSION number -- GBARR */
651 version = yylval.opval;
655 /* NOTE: The parser sees the package name and the VERSION swapped */
656 PL_nextval[PL_nexttoke].opval = version;
674 s = SvPV_force(sv, len);
678 while (s < send && *s != '\\')
683 if ( PL_hints & HINT_NEW_STRING )
684 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
687 if (s + 1 < send && (s[1] == '\\'))
688 s++; /* all that, just for this */
693 SvCUR_set(sv, d - SvPVX(sv));
695 if ( PL_hints & HINT_NEW_STRING )
696 return new_constant(NULL, 0, "q", sv, pv, "q");
703 register I32 op_type = yylval.ival;
705 if (op_type == OP_NULL) {
706 yylval.opval = PL_lex_op;
710 if (op_type == OP_CONST || op_type == OP_READLINE) {
711 SV *sv = tokeq(PL_lex_stuff);
713 if (SvTYPE(sv) == SVt_PVIV) {
714 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
720 nsv = newSVpv(p, len);
724 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
725 PL_lex_stuff = Nullsv;
729 PL_sublex_info.super_state = PL_lex_state;
730 PL_sublex_info.sub_inwhat = op_type;
731 PL_sublex_info.sub_op = PL_lex_op;
732 PL_lex_state = LEX_INTERPPUSH;
736 yylval.opval = PL_lex_op;
750 PL_lex_state = PL_sublex_info.super_state;
751 SAVEI32(PL_lex_dojoin);
752 SAVEI32(PL_lex_brackets);
753 SAVEI32(PL_lex_fakebrack);
754 SAVEI32(PL_lex_casemods);
755 SAVEI32(PL_lex_starts);
756 SAVEI32(PL_lex_state);
757 SAVESPTR(PL_lex_inpat);
758 SAVEI32(PL_lex_inwhat);
759 SAVEI16(PL_curcop->cop_line);
761 SAVEPPTR(PL_oldbufptr);
762 SAVEPPTR(PL_oldoldbufptr);
763 SAVEPPTR(PL_linestart);
764 SAVESPTR(PL_linestr);
765 SAVEPPTR(PL_lex_brackstack);
766 SAVEPPTR(PL_lex_casestack);
768 PL_linestr = PL_lex_stuff;
769 PL_lex_stuff = Nullsv;
771 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
772 PL_bufend += SvCUR(PL_linestr);
773 SAVEFREESV(PL_linestr);
775 PL_lex_dojoin = FALSE;
777 PL_lex_fakebrack = 0;
778 New(899, PL_lex_brackstack, 120, char);
779 New(899, PL_lex_casestack, 12, char);
780 SAVEFREEPV(PL_lex_brackstack);
781 SAVEFREEPV(PL_lex_casestack);
783 *PL_lex_casestack = '\0';
785 PL_lex_state = LEX_INTERPCONCAT;
786 PL_curcop->cop_line = PL_multi_start;
788 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
789 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
790 PL_lex_inpat = PL_sublex_info.sub_op;
792 PL_lex_inpat = Nullop;
800 if (!PL_lex_starts++) {
801 PL_expect = XOPERATOR;
802 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
806 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
807 PL_lex_state = LEX_INTERPCASEMOD;
808 return yylex(PERL_YYLEX_PARAM);
811 /* Is there a right-hand side to take care of? */
812 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
813 PL_linestr = PL_lex_repl;
815 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
816 PL_bufend += SvCUR(PL_linestr);
817 SAVEFREESV(PL_linestr);
818 PL_lex_dojoin = FALSE;
820 PL_lex_fakebrack = 0;
822 *PL_lex_casestack = '\0';
824 if (SvCOMPILED(PL_lex_repl)) {
825 PL_lex_state = LEX_INTERPNORMAL;
827 /* we don't clear PL_lex_repl here, so that we can check later
828 whether this is an evalled subst; that means we rely on the
829 logic to ensure sublex_done() is called again only via the
830 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
833 PL_lex_state = LEX_INTERPCONCAT;
834 PL_lex_repl = Nullsv;
840 PL_bufend = SvPVX(PL_linestr);
841 PL_bufend += SvCUR(PL_linestr);
842 PL_expect = XOPERATOR;
850 Extracts a pattern, double-quoted string, or transliteration. This
853 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
854 processing a pattern (PL_lex_inpat is true), a transliteration
855 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
857 Returns a pointer to the character scanned up to. Iff this is
858 advanced from the start pointer supplied (ie if anything was
859 successfully parsed), will leave an OP for the substring scanned
860 in yylval. Caller must intuit reason for not parsing further
861 by looking at the next characters herself.
865 double-quoted style: \r and \n
866 regexp special ones: \D \s
868 backrefs: \1 (deprecated in substitution replacements)
869 case and quoting: \U \Q \E
870 stops on @ and $, but not for $ as tail anchor
873 characters are VERY literal, except for - not at the start or end
874 of the string, which indicates a range. scan_const expands the
875 range to the full set of intermediate characters.
877 In double-quoted strings:
879 double-quoted style: \r and \n
881 backrefs: \1 (deprecated)
882 case and quoting: \U \Q \E
885 scan_const does *not* construct ops to handle interpolated strings.
886 It stops processing as soon as it finds an embedded $ or @ variable
887 and leaves it to the caller to work out what's going on.
889 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
891 $ in pattern could be $foo or could be tail anchor. Assumption:
892 it's a tail anchor if $ is the last thing in the string, or if it's
893 followed by one of ")| \n\t"
895 \1 (backreferences) are turned into $1
897 The structure of the code is
898 while (there's a character to process) {
899 handle transliteration ranges
901 skip # initiated comments in //x patterns
902 check for embedded @foo
903 check for embedded scalars
905 leave intact backslashes from leave (below)
906 deprecate \1 in strings and sub replacements
907 handle string-changing backslashes \l \U \Q \E, etc.
908 switch (what was escaped) {
909 handle - in a transliteration (becomes a literal -)
910 handle \132 octal characters
911 handle 0x15 hex characters
912 handle \cV (control V)
913 handle printf backslashes (\f, \r, \n, etc)
916 } (end while character to read)
921 scan_const(char *start)
923 register char *send = PL_bufend; /* end of the constant */
924 SV *sv = NEWSV(93, send - start); /* sv for the constant */
925 register char *s = start; /* start of the constant */
926 register char *d = SvPVX(sv); /* destination for copies */
927 bool dorange = FALSE; /* are we in a translit range? */
929 I32 utf = PL_lex_inwhat == OP_TRANS
930 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
932 I32 thisutf = PL_lex_inwhat == OP_TRANS
933 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
936 /* leaveit is the set of acceptably-backslashed characters */
939 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
942 while (s < send || dorange) {
943 /* get transliterations out of the way (they're most literal) */
944 if (PL_lex_inwhat == OP_TRANS) {
945 /* expand a range A-Z to the full set of characters. AIE! */
947 I32 i; /* current expanded character */
948 I32 min; /* first character in range */
949 I32 max; /* last character in range */
951 i = d - SvPVX(sv); /* remember current offset */
952 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
953 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
954 d -= 2; /* eat the first char and the - */
956 min = (U8)*d; /* first char in range */
957 max = (U8)d[1]; /* last char in range */
960 if ((isLOWER(min) && isLOWER(max)) ||
961 (isUPPER(min) && isUPPER(max))) {
963 for (i = min; i <= max; i++)
967 for (i = min; i <= max; i++)
974 for (i = min; i <= max; i++)
977 /* mark the range as done, and continue */
982 /* range begins (ignore - as first or last char) */
983 else if (*s == '-' && s+1 < send && s != start) {
985 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
994 /* if we get here, we're not doing a transliteration */
996 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
997 except for the last char, which will be done separately. */
998 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1000 while (s < send && *s != ')')
1002 } else if (s[2] == '{'
1003 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1005 char *regparse = s + (s[2] == '{' ? 3 : 4);
1008 while (count && (c = *regparse)) {
1009 if (c == '\\' && regparse[1])
1017 if (*regparse != ')') {
1018 regparse--; /* Leave one char for continuation. */
1019 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1021 while (s < regparse)
1026 /* likewise skip #-initiated comments in //x patterns */
1027 else if (*s == '#' && PL_lex_inpat &&
1028 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1029 while (s+1 < send && *s != '\n')
1033 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1034 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1037 /* check for embedded scalars. only stop if we're sure it's a
1040 else if (*s == '$') {
1041 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1043 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1044 break; /* in regexp, $ might be tail anchor */
1047 /* (now in tr/// code again) */
1049 if (*s & 0x80 && thisutf) {
1050 dTHR; /* only for ckWARN */
1051 if (ckWARN(WARN_UTF8)) {
1052 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1062 if (*s == '\\' && s+1 < send) {
1065 /* some backslashes we leave behind */
1066 if (*leaveit && *s && strchr(leaveit, *s)) {
1072 /* deprecate \1 in strings and substitution replacements */
1073 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1074 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1076 dTHR; /* only for ckWARN */
1077 if (ckWARN(WARN_SYNTAX))
1078 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1083 /* string-change backslash escapes */
1084 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1089 /* if we get here, it's either a quoted -, or a digit */
1092 /* quoted - in transliterations */
1094 if (PL_lex_inwhat == OP_TRANS) {
1102 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1104 "Unrecognized escape \\%c passed through",
1106 /* default action is to copy the quoted character */
1111 /* \132 indicates an octal constant */
1112 case '0': case '1': case '2': case '3':
1113 case '4': case '5': case '6': case '7':
1114 *d++ = scan_oct(s, 3, &len);
1118 /* \x24 indicates a hex constant */
1122 char* e = strchr(s, '}');
1125 yyerror("Missing right brace on \\x{}");
1130 if (ckWARN(WARN_UTF8))
1132 "Use of \\x{} without utf8 declaration");
1134 /* note: utf always shorter than hex */
1135 d = (char*)uv_to_utf8((U8*)d,
1136 scan_hex(s + 1, e - s - 1, &len));
1141 UV uv = (UV)scan_hex(s, 2, &len);
1142 if (utf && PL_lex_inwhat == OP_TRANS &&
1143 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1145 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1148 if (uv >= 127 && UTF) {
1150 if (ckWARN(WARN_UTF8))
1152 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1161 /* \c is a control character */
1175 /* printf-style backslashes, formfeeds, newlines, etc */
1201 } /* end if (backslash) */
1204 } /* while loop to process each character */
1206 /* terminate the string and set up the sv */
1208 SvCUR_set(sv, d - SvPVX(sv));
1211 /* shrink the sv if we allocated more than we used */
1212 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1213 SvLEN_set(sv, SvCUR(sv) + 1);
1214 Renew(SvPVX(sv), SvLEN(sv), char);
1217 /* return the substring (via yylval) only if we parsed anything */
1218 if (s > PL_bufptr) {
1219 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1220 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1222 ( PL_lex_inwhat == OP_TRANS
1224 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1227 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1233 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1235 intuit_more(register char *s)
1237 if (PL_lex_brackets)
1239 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1241 if (*s != '{' && *s != '[')
1246 /* In a pattern, so maybe we have {n,m}. */
1263 /* On the other hand, maybe we have a character class */
1266 if (*s == ']' || *s == '^')
1269 int weight = 2; /* let's weigh the evidence */
1271 unsigned char un_char = 255, last_un_char;
1272 char *send = strchr(s,']');
1273 char tmpbuf[sizeof PL_tokenbuf * 4];
1275 if (!send) /* has to be an expression */
1278 Zero(seen,256,char);
1281 else if (isDIGIT(*s)) {
1283 if (isDIGIT(s[1]) && s[2] == ']')
1289 for (; s < send; s++) {
1290 last_un_char = un_char;
1291 un_char = (unsigned char)*s;
1296 weight -= seen[un_char] * 10;
1297 if (isALNUM_lazy(s+1)) {
1298 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1299 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1304 else if (*s == '$' && s[1] &&
1305 strchr("[#!%*<>()-=",s[1])) {
1306 if (/*{*/ strchr("])} =",s[2]))
1315 if (strchr("wds]",s[1]))
1317 else if (seen['\''] || seen['"'])
1319 else if (strchr("rnftbxcav",s[1]))
1321 else if (isDIGIT(s[1])) {
1323 while (s[1] && isDIGIT(s[1]))
1333 if (strchr("aA01! ",last_un_char))
1335 if (strchr("zZ79~",s[1]))
1337 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1338 weight -= 5; /* cope with negative subscript */
1341 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1342 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1347 if (keyword(tmpbuf, d - tmpbuf))
1350 if (un_char == last_un_char + 1)
1352 weight -= seen[un_char];
1357 if (weight >= 0) /* probably a character class */
1365 intuit_method(char *start, GV *gv)
1367 char *s = start + (*start == '$');
1368 char tmpbuf[sizeof PL_tokenbuf];
1376 if ((cv = GvCVu(gv))) {
1377 char *proto = SvPVX(cv);
1387 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1388 if (*start == '$') {
1389 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1394 return *s == '(' ? FUNCMETH : METHOD;
1396 if (!keyword(tmpbuf, len)) {
1397 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1402 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1403 if (indirgv && GvCVu(indirgv))
1405 /* filehandle or package name makes it a method */
1406 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1408 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1409 return 0; /* no assumptions -- "=>" quotes bearword */
1411 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1413 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1417 return *s == '(' ? FUNCMETH : METHOD;
1427 char *pdb = PerlEnv_getenv("PERL5DB");
1431 SETERRNO(0,SS$_NORMAL);
1432 return "BEGIN { require 'perl5db.pl' }";
1438 /* Encoded script support. filter_add() effectively inserts a
1439 * 'pre-processing' function into the current source input stream.
1440 * Note that the filter function only applies to the current source file
1441 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1443 * The datasv parameter (which may be NULL) can be used to pass
1444 * private data to this instance of the filter. The filter function
1445 * can recover the SV using the FILTER_DATA macro and use it to
1446 * store private buffers and state information.
1448 * The supplied datasv parameter is upgraded to a PVIO type
1449 * and the IoDIRP field is used to store the function pointer.
1450 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1451 * private use must be set using malloc'd pointers.
1455 filter_add(filter_t funcp, SV *datasv)
1457 if (!funcp){ /* temporary handy debugging hack to be deleted */
1458 PL_filter_debug = atoi((char*)datasv);
1461 if (!PL_rsfp_filters)
1462 PL_rsfp_filters = newAV();
1464 datasv = NEWSV(255,0);
1465 if (!SvUPGRADE(datasv, SVt_PVIO))
1466 die("Can't upgrade filter_add data to SVt_PVIO");
1467 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1468 if (PL_filter_debug) {
1470 warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1472 av_unshift(PL_rsfp_filters, 1);
1473 av_store(PL_rsfp_filters, 0, datasv) ;
1478 /* Delete most recently added instance of this filter function. */
1480 filter_del(filter_t funcp)
1482 if (PL_filter_debug)
1483 warn("filter_del func %p", funcp);
1484 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1486 /* if filter is on top of stack (usual case) just pop it off */
1487 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1488 sv_free(av_pop(PL_rsfp_filters));
1492 /* we need to search for the correct entry and clear it */
1493 die("filter_del can only delete in reverse order (currently)");
1497 /* Invoke the n'th filter function for the current rsfp. */
1499 filter_read(int idx, SV *buf_sv, int maxlen)
1502 /* 0 = read one text line */
1507 if (!PL_rsfp_filters)
1509 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1510 /* Provide a default input filter to make life easy. */
1511 /* Note that we append to the line. This is handy. */
1512 if (PL_filter_debug)
1513 warn("filter_read %d: from rsfp\n", idx);
1517 int old_len = SvCUR(buf_sv) ;
1519 /* ensure buf_sv is large enough */
1520 SvGROW(buf_sv, old_len + maxlen) ;
1521 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1522 if (PerlIO_error(PL_rsfp))
1523 return -1; /* error */
1525 return 0 ; /* end of file */
1527 SvCUR_set(buf_sv, old_len + len) ;
1530 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1531 if (PerlIO_error(PL_rsfp))
1532 return -1; /* error */
1534 return 0 ; /* end of file */
1537 return SvCUR(buf_sv);
1539 /* Skip this filter slot if filter has been deleted */
1540 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1541 if (PL_filter_debug)
1542 warn("filter_read %d: skipped (filter deleted)\n", idx);
1543 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1545 /* Get function pointer hidden within datasv */
1546 funcp = (filter_t)IoDIRP(datasv);
1547 if (PL_filter_debug) {
1549 warn("filter_read %d: via function %p (%s)\n",
1550 idx, funcp, SvPV(datasv,n_a));
1552 /* Call function. The function is expected to */
1553 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1554 /* Return: <0:error, =0:eof, >0:not eof */
1555 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1559 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1562 if (!PL_rsfp_filters) {
1563 filter_add(win32_textfilter,NULL);
1566 if (PL_rsfp_filters) {
1569 SvCUR_set(sv, 0); /* start with empty line */
1570 if (FILTER_READ(0, sv, 0) > 0)
1571 return ( SvPVX(sv) ) ;
1576 return (sv_gets(sv, fp, append));
1581 static char* exp_name[] =
1582 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1588 Works out what to call the token just pulled out of the input
1589 stream. The yacc parser takes care of taking the ops we return and
1590 stitching them into a tree.
1596 if read an identifier
1597 if we're in a my declaration
1598 croak if they tried to say my($foo::bar)
1599 build the ops for a my() declaration
1600 if it's an access to a my() variable
1601 are we in a sort block?
1602 croak if my($a); $a <=> $b
1603 build ops for access to a my() variable
1604 if in a dq string, and they've said @foo and we can't find @foo
1606 build ops for a bareword
1607 if we already built the token before, use it.
1610 int yylex(PERL_YYLEX_PARAM_DECL)
1620 #ifdef USE_PURE_BISON
1621 yylval_pointer = lvalp;
1622 yychar_pointer = lcharp;
1625 /* check if there's an identifier for us to look at */
1626 if (PL_pending_ident) {
1627 /* pit holds the identifier we read and pending_ident is reset */
1628 char pit = PL_pending_ident;
1629 PL_pending_ident = 0;
1631 /* if we're in a my(), we can't allow dynamics here.
1632 $foo'bar has already been turned into $foo::bar, so
1633 just check for colons.
1635 if it's a legal name, the OP is a PADANY.
1638 if (strchr(PL_tokenbuf,':'))
1639 croak(PL_no_myglob,PL_tokenbuf);
1641 yylval.opval = newOP(OP_PADANY, 0);
1642 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1647 build the ops for accesses to a my() variable.
1649 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1650 then used in a comparison. This catches most, but not
1651 all cases. For instance, it catches
1652 sort { my($a); $a <=> $b }
1654 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1655 (although why you'd do that is anyone's guess).
1658 if (!strchr(PL_tokenbuf,':')) {
1660 /* Check for single character per-thread SVs */
1661 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1662 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1663 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1665 yylval.opval = newOP(OP_THREADSV, 0);
1666 yylval.opval->op_targ = tmp;
1669 #endif /* USE_THREADS */
1670 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1671 /* if it's a sort block and they're naming $a or $b */
1672 if (PL_last_lop_op == OP_SORT &&
1673 PL_tokenbuf[0] == '$' &&
1674 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1677 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1678 d < PL_bufend && *d != '\n';
1681 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1682 croak("Can't use \"my %s\" in sort comparison",
1688 yylval.opval = newOP(OP_PADANY, 0);
1689 yylval.opval->op_targ = tmp;
1695 Whine if they've said @foo in a doublequoted string,
1696 and @foo isn't a variable we can find in the symbol
1699 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1700 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1701 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1702 yyerror(form("In string, %s now must be written as \\%s",
1703 PL_tokenbuf, PL_tokenbuf));
1706 /* build ops for a bareword */
1707 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1708 yylval.opval->op_private = OPpCONST_ENTERED;
1709 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1710 ((PL_tokenbuf[0] == '$') ? SVt_PV
1711 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1716 /* no identifier pending identification */
1718 switch (PL_lex_state) {
1720 case LEX_NORMAL: /* Some compilers will produce faster */
1721 case LEX_INTERPNORMAL: /* code if we comment these out. */
1725 /* when we're already built the next token, just pull it out the queue */
1728 yylval = PL_nextval[PL_nexttoke];
1730 PL_lex_state = PL_lex_defer;
1731 PL_expect = PL_lex_expect;
1732 PL_lex_defer = LEX_NORMAL;
1734 return(PL_nexttype[PL_nexttoke]);
1736 /* interpolated case modifiers like \L \U, including \Q and \E.
1737 when we get here, PL_bufptr is at the \
1739 case LEX_INTERPCASEMOD:
1741 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1742 croak("panic: INTERPCASEMOD");
1744 /* handle \E or end of string */
1745 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1749 if (PL_lex_casemods) {
1750 oldmod = PL_lex_casestack[--PL_lex_casemods];
1751 PL_lex_casestack[PL_lex_casemods] = '\0';
1753 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1755 PL_lex_state = LEX_INTERPCONCAT;
1759 if (PL_bufptr != PL_bufend)
1761 PL_lex_state = LEX_INTERPCONCAT;
1762 return yylex(PERL_YYLEX_PARAM);
1766 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1767 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1768 if (strchr("LU", *s) &&
1769 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1771 PL_lex_casestack[--PL_lex_casemods] = '\0';
1774 if (PL_lex_casemods > 10) {
1775 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1776 if (newlb != PL_lex_casestack) {
1778 PL_lex_casestack = newlb;
1781 PL_lex_casestack[PL_lex_casemods++] = *s;
1782 PL_lex_casestack[PL_lex_casemods] = '\0';
1783 PL_lex_state = LEX_INTERPCONCAT;
1784 PL_nextval[PL_nexttoke].ival = 0;
1787 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1789 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1791 PL_nextval[PL_nexttoke].ival = OP_LC;
1793 PL_nextval[PL_nexttoke].ival = OP_UC;
1795 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1797 croak("panic: yylex");
1800 if (PL_lex_starts) {
1806 return yylex(PERL_YYLEX_PARAM);
1809 case LEX_INTERPPUSH:
1810 return sublex_push();
1812 case LEX_INTERPSTART:
1813 if (PL_bufptr == PL_bufend)
1814 return sublex_done();
1816 PL_lex_dojoin = (*PL_bufptr == '@');
1817 PL_lex_state = LEX_INTERPNORMAL;
1818 if (PL_lex_dojoin) {
1819 PL_nextval[PL_nexttoke].ival = 0;
1822 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1823 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1824 force_next(PRIVATEREF);
1826 force_ident("\"", '$');
1827 #endif /* USE_THREADS */
1828 PL_nextval[PL_nexttoke].ival = 0;
1830 PL_nextval[PL_nexttoke].ival = 0;
1832 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1835 if (PL_lex_starts++) {
1839 return yylex(PERL_YYLEX_PARAM);
1841 case LEX_INTERPENDMAYBE:
1842 if (intuit_more(PL_bufptr)) {
1843 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1849 if (PL_lex_dojoin) {
1850 PL_lex_dojoin = FALSE;
1851 PL_lex_state = LEX_INTERPCONCAT;
1854 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl && SvCOMPILED(PL_lex_repl)) {
1855 if (PL_bufptr != PL_bufend)
1856 croak("Bad evalled substitution pattern");
1857 PL_lex_repl = Nullsv;
1860 case LEX_INTERPCONCAT:
1862 if (PL_lex_brackets)
1863 croak("panic: INTERPCONCAT");
1865 if (PL_bufptr == PL_bufend)
1866 return sublex_done();
1868 if (SvIVX(PL_linestr) == '\'') {
1869 SV *sv = newSVsv(PL_linestr);
1872 else if ( PL_hints & HINT_NEW_RE )
1873 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1874 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1878 s = scan_const(PL_bufptr);
1880 PL_lex_state = LEX_INTERPCASEMOD;
1882 PL_lex_state = LEX_INTERPSTART;
1885 if (s != PL_bufptr) {
1886 PL_nextval[PL_nexttoke] = yylval;
1889 if (PL_lex_starts++)
1893 return yylex(PERL_YYLEX_PARAM);
1897 return yylex(PERL_YYLEX_PARAM);
1899 PL_lex_state = LEX_NORMAL;
1900 s = scan_formline(PL_bufptr);
1901 if (!PL_lex_formbrack)
1907 PL_oldoldbufptr = PL_oldbufptr;
1910 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1916 if (isIDFIRST_lazy(s))
1918 croak("Unrecognized character \\x%02X", *s & 255);
1921 goto fake_eof; /* emulate EOF on ^D or ^Z */
1926 if (PL_lex_brackets)
1927 yyerror("Missing right bracket");
1930 if (s++ < PL_bufend)
1931 goto retry; /* ignore stray nulls */
1934 if (!PL_in_eval && !PL_preambled) {
1935 PL_preambled = TRUE;
1936 sv_setpv(PL_linestr,incl_perldb());
1937 if (SvCUR(PL_linestr))
1938 sv_catpv(PL_linestr,";");
1940 while(AvFILLp(PL_preambleav) >= 0) {
1941 SV *tmpsv = av_shift(PL_preambleav);
1942 sv_catsv(PL_linestr, tmpsv);
1943 sv_catpv(PL_linestr, ";");
1946 sv_free((SV*)PL_preambleav);
1947 PL_preambleav = NULL;
1949 if (PL_minus_n || PL_minus_p) {
1950 sv_catpv(PL_linestr, "LINE: while (<>) {");
1952 sv_catpv(PL_linestr,"chomp;");
1954 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1956 GvIMPORTED_AV_on(gv);
1958 if (strchr("/'\"", *PL_splitstr)
1959 && strchr(PL_splitstr + 1, *PL_splitstr))
1960 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1963 s = "'~#\200\1'"; /* surely one char is unused...*/
1964 while (s[1] && strchr(PL_splitstr, *s)) s++;
1966 sv_catpvf(PL_linestr, "@F=split(%s%c",
1967 "q" + (delim == '\''), delim);
1968 for (s = PL_splitstr; *s; s++) {
1970 sv_catpvn(PL_linestr, "\\", 1);
1971 sv_catpvn(PL_linestr, s, 1);
1973 sv_catpvf(PL_linestr, "%c);", delim);
1977 sv_catpv(PL_linestr,"@F=split(' ');");
1980 sv_catpv(PL_linestr, "\n");
1981 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1982 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1983 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1984 SV *sv = NEWSV(85,0);
1986 sv_upgrade(sv, SVt_PVMG);
1987 sv_setsv(sv,PL_linestr);
1988 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1993 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1996 if (PL_preprocess && !PL_in_eval)
1997 (void)PerlProc_pclose(PL_rsfp);
1998 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1999 PerlIO_clearerr(PL_rsfp);
2001 (void)PerlIO_close(PL_rsfp);
2003 PL_doextract = FALSE;
2005 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2006 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2007 sv_catpv(PL_linestr,";}");
2008 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2009 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2010 PL_minus_n = PL_minus_p = 0;
2013 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2014 sv_setpv(PL_linestr,"");
2015 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2018 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2019 PL_doextract = FALSE;
2021 /* Incest with pod. */
2022 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2023 sv_setpv(PL_linestr, "");
2024 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2025 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2026 PL_doextract = FALSE;
2030 } while (PL_doextract);
2031 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2032 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2033 SV *sv = NEWSV(85,0);
2035 sv_upgrade(sv, SVt_PVMG);
2036 sv_setsv(sv,PL_linestr);
2037 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2039 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2040 if (PL_curcop->cop_line == 1) {
2041 while (s < PL_bufend && isSPACE(*s))
2043 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2047 if (*s == '#' && *(s+1) == '!')
2049 #ifdef ALTERNATE_SHEBANG
2051 static char as[] = ALTERNATE_SHEBANG;
2052 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2053 d = s + (sizeof(as) - 1);
2055 #endif /* ALTERNATE_SHEBANG */
2064 while (*d && !isSPACE(*d))
2068 #ifdef ARG_ZERO_IS_SCRIPT
2069 if (ipathend > ipath) {
2071 * HP-UX (at least) sets argv[0] to the script name,
2072 * which makes $^X incorrect. And Digital UNIX and Linux,
2073 * at least, set argv[0] to the basename of the Perl
2074 * interpreter. So, having found "#!", we'll set it right.
2076 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2077 assert(SvPOK(x) || SvGMAGICAL(x));
2078 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2079 sv_setpvn(x, ipath, ipathend - ipath);
2082 TAINT_NOT; /* $^X is always tainted, but that's OK */
2084 #endif /* ARG_ZERO_IS_SCRIPT */
2089 d = instr(s,"perl -");
2091 d = instr(s,"perl");
2092 #ifdef ALTERNATE_SHEBANG
2094 * If the ALTERNATE_SHEBANG on this system starts with a
2095 * character that can be part of a Perl expression, then if
2096 * we see it but not "perl", we're probably looking at the
2097 * start of Perl code, not a request to hand off to some
2098 * other interpreter. Similarly, if "perl" is there, but
2099 * not in the first 'word' of the line, we assume the line
2100 * contains the start of the Perl program.
2102 if (d && *s != '#') {
2104 while (*c && !strchr("; \t\r\n\f\v#", *c))
2107 d = Nullch; /* "perl" not in first word; ignore */
2109 *s = '#'; /* Don't try to parse shebang line */
2111 #endif /* ALTERNATE_SHEBANG */
2116 !instr(s,"indir") &&
2117 instr(PL_origargv[0],"perl"))
2123 while (s < PL_bufend && isSPACE(*s))
2125 if (s < PL_bufend) {
2126 Newz(899,newargv,PL_origargc+3,char*);
2128 while (s < PL_bufend && !isSPACE(*s))
2131 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2134 newargv = PL_origargv;
2136 PerlProc_execv(ipath, newargv);
2137 croak("Can't exec %s", ipath);
2140 U32 oldpdb = PL_perldb;
2141 bool oldn = PL_minus_n;
2142 bool oldp = PL_minus_p;
2144 while (*d && !isSPACE(*d)) d++;
2145 while (*d == ' ' || *d == '\t') d++;
2149 if (*d == 'M' || *d == 'm') {
2151 while (*d && !isSPACE(*d)) d++;
2152 croak("Too late for \"-%.*s\" option",
2155 d = moreswitches(d);
2157 if (PERLDB_LINE && !oldpdb ||
2158 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2159 /* if we have already added "LINE: while (<>) {",
2160 we must not do it again */
2162 sv_setpv(PL_linestr, "");
2163 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2164 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2165 PL_preambled = FALSE;
2167 (void)gv_fetchfile(PL_origfilename);
2174 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2176 PL_lex_state = LEX_FORMLINE;
2177 return yylex(PERL_YYLEX_PARAM);
2181 #ifdef PERL_STRICT_CR
2182 warn("Illegal character \\%03o (carriage return)", '\r');
2184 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2186 case ' ': case '\t': case '\f': case 013:
2191 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2193 while (s < d && *s != '\n')
2198 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2200 PL_lex_state = LEX_FORMLINE;
2201 return yylex(PERL_YYLEX_PARAM);
2210 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2215 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2218 if (strnEQ(s,"=>",2)) {
2219 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2220 OPERATOR('-'); /* unary minus */
2222 PL_last_uni = PL_oldbufptr;
2223 PL_last_lop_op = OP_FTEREAD; /* good enough */
2225 case 'r': FTST(OP_FTEREAD);
2226 case 'w': FTST(OP_FTEWRITE);
2227 case 'x': FTST(OP_FTEEXEC);
2228 case 'o': FTST(OP_FTEOWNED);
2229 case 'R': FTST(OP_FTRREAD);
2230 case 'W': FTST(OP_FTRWRITE);
2231 case 'X': FTST(OP_FTREXEC);
2232 case 'O': FTST(OP_FTROWNED);
2233 case 'e': FTST(OP_FTIS);
2234 case 'z': FTST(OP_FTZERO);
2235 case 's': FTST(OP_FTSIZE);
2236 case 'f': FTST(OP_FTFILE);
2237 case 'd': FTST(OP_FTDIR);
2238 case 'l': FTST(OP_FTLINK);
2239 case 'p': FTST(OP_FTPIPE);
2240 case 'S': FTST(OP_FTSOCK);
2241 case 'u': FTST(OP_FTSUID);
2242 case 'g': FTST(OP_FTSGID);
2243 case 'k': FTST(OP_FTSVTX);
2244 case 'b': FTST(OP_FTBLK);
2245 case 'c': FTST(OP_FTCHR);
2246 case 't': FTST(OP_FTTTY);
2247 case 'T': FTST(OP_FTTEXT);
2248 case 'B': FTST(OP_FTBINARY);
2249 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2250 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2251 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2253 croak("Unrecognized file test: -%c", (int)tmp);
2260 if (PL_expect == XOPERATOR)
2265 else if (*s == '>') {
2268 if (isIDFIRST_lazy(s)) {
2269 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2277 if (PL_expect == XOPERATOR)
2280 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2282 OPERATOR('-'); /* unary minus */
2289 if (PL_expect == XOPERATOR)
2294 if (PL_expect == XOPERATOR)
2297 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2303 if (PL_expect != XOPERATOR) {
2304 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2305 PL_expect = XOPERATOR;
2306 force_ident(PL_tokenbuf, '*');
2319 if (PL_expect == XOPERATOR) {
2323 PL_tokenbuf[0] = '%';
2324 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2325 if (!PL_tokenbuf[1]) {
2327 yyerror("Final % should be \\% or %name");
2330 PL_pending_ident = '%';
2352 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2353 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2358 if (PL_curcop->cop_line < PL_copline)
2359 PL_copline = PL_curcop->cop_line;
2370 if (PL_lex_brackets <= 0)
2371 yyerror("Unmatched right bracket");
2374 if (PL_lex_state == LEX_INTERPNORMAL) {
2375 if (PL_lex_brackets == 0) {
2376 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2377 PL_lex_state = LEX_INTERPEND;
2384 if (PL_lex_brackets > 100) {
2385 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2386 if (newlb != PL_lex_brackstack) {
2388 PL_lex_brackstack = newlb;
2391 switch (PL_expect) {
2393 if (PL_lex_formbrack) {
2397 if (PL_oldoldbufptr == PL_last_lop)
2398 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2400 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2401 OPERATOR(HASHBRACK);
2403 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2406 PL_tokenbuf[0] = '\0';
2407 if (d < PL_bufend && *d == '-') {
2408 PL_tokenbuf[0] = '-';
2410 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2413 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2414 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2416 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2419 char minus = (PL_tokenbuf[0] == '-');
2420 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2427 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2431 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2436 if (PL_oldoldbufptr == PL_last_lop)
2437 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2439 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2442 OPERATOR(HASHBRACK);
2443 /* This hack serves to disambiguate a pair of curlies
2444 * as being a block or an anon hash. Normally, expectation
2445 * determines that, but in cases where we're not in a
2446 * position to expect anything in particular (like inside
2447 * eval"") we have to resolve the ambiguity. This code
2448 * covers the case where the first term in the curlies is a
2449 * quoted string. Most other cases need to be explicitly
2450 * disambiguated by prepending a `+' before the opening
2451 * curly in order to force resolution as an anon hash.
2453 * XXX should probably propagate the outer expectation
2454 * into eval"" to rely less on this hack, but that could
2455 * potentially break current behavior of eval"".
2459 if (*s == '\'' || *s == '"' || *s == '`') {
2460 /* common case: get past first string, handling escapes */
2461 for (t++; t < PL_bufend && *t != *s;)
2462 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2466 else if (*s == 'q') {
2469 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2470 && !isALNUM(*t)))) {
2472 char open, close, term;
2475 while (t < PL_bufend && isSPACE(*t))
2479 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2483 for (t++; t < PL_bufend; t++) {
2484 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2486 else if (*t == open)
2490 for (t++; t < PL_bufend; t++) {
2491 if (*t == '\\' && t+1 < PL_bufend)
2493 else if (*t == close && --brackets <= 0)
2495 else if (*t == open)
2501 else if (isIDFIRST_lazy(s)) {
2502 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2504 while (t < PL_bufend && isSPACE(*t))
2506 /* if comma follows first term, call it an anon hash */
2507 /* XXX it could be a comma expression with loop modifiers */
2508 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2509 || (*t == '=' && t[1] == '>')))
2510 OPERATOR(HASHBRACK);
2511 if (PL_expect == XREF)
2512 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2514 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2520 yylval.ival = PL_curcop->cop_line;
2521 if (isSPACE(*s) || *s == '#')
2522 PL_copline = NOLINE; /* invalidate current command line number */
2527 if (PL_lex_brackets <= 0)
2528 yyerror("Unmatched right bracket");
2530 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2531 if (PL_lex_brackets < PL_lex_formbrack)
2532 PL_lex_formbrack = 0;
2533 if (PL_lex_state == LEX_INTERPNORMAL) {
2534 if (PL_lex_brackets == 0) {
2535 if (PL_lex_fakebrack) {
2536 PL_lex_state = LEX_INTERPEND;
2538 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2540 if (*s == '-' && s[1] == '>')
2541 PL_lex_state = LEX_INTERPENDMAYBE;
2542 else if (*s != '[' && *s != '{')
2543 PL_lex_state = LEX_INTERPEND;
2546 if (PL_lex_brackets < PL_lex_fakebrack) {
2548 PL_lex_fakebrack = 0;
2549 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2559 if (PL_expect == XOPERATOR) {
2560 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2561 PL_curcop->cop_line--;
2562 warner(WARN_SEMICOLON, PL_warn_nosemi);
2563 PL_curcop->cop_line++;
2568 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2570 PL_expect = XOPERATOR;
2571 force_ident(PL_tokenbuf, '&');
2575 yylval.ival = (OPpENTERSUB_AMPER<<8);
2594 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2595 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2597 if (PL_expect == XSTATE && isALPHA(tmp) &&
2598 (s == PL_linestart+1 || s[-2] == '\n') )
2600 if (PL_in_eval && !PL_rsfp) {
2605 if (strnEQ(s,"=cut",4)) {
2619 PL_doextract = TRUE;
2622 if (PL_lex_brackets < PL_lex_formbrack) {
2624 #ifdef PERL_STRICT_CR
2625 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2627 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2629 if (*t == '\n' || *t == '#') {
2647 if (PL_expect != XOPERATOR) {
2648 if (s[1] != '<' && !strchr(s,'>'))
2651 s = scan_heredoc(s);
2653 s = scan_inputsymbol(s);
2654 TERM(sublex_start());
2659 SHop(OP_LEFT_SHIFT);
2673 SHop(OP_RIGHT_SHIFT);
2682 if (PL_expect == XOPERATOR) {
2683 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2686 return ','; /* grandfather non-comma-format format */
2690 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2691 if (PL_expect == XOPERATOR)
2692 no_op("Array length", PL_bufptr);
2693 PL_tokenbuf[0] = '@';
2694 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2696 if (!PL_tokenbuf[1])
2698 PL_expect = XOPERATOR;
2699 PL_pending_ident = '#';
2703 if (PL_expect == XOPERATOR)
2704 no_op("Scalar", PL_bufptr);
2705 PL_tokenbuf[0] = '$';
2706 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2707 if (!PL_tokenbuf[1]) {
2709 yyerror("Final $ should be \\$ or $name");
2713 /* This kludge not intended to be bulletproof. */
2714 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2715 yylval.opval = newSVOP(OP_CONST, 0,
2716 newSViv((IV)PL_compiling.cop_arybase));
2717 yylval.opval->op_private = OPpCONST_ARYBASE;
2722 if (PL_lex_state == LEX_NORMAL)
2725 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2728 PL_tokenbuf[0] = '@';
2729 if (ckWARN(WARN_SYNTAX)) {
2731 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2734 PL_bufptr = skipspace(PL_bufptr);
2735 while (t < PL_bufend && *t != ']')
2738 "Multidimensional syntax %.*s not supported",
2739 (t - PL_bufptr) + 1, PL_bufptr);
2743 else if (*s == '{') {
2744 PL_tokenbuf[0] = '%';
2745 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2746 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2748 char tmpbuf[sizeof PL_tokenbuf];
2750 for (t++; isSPACE(*t); t++) ;
2751 if (isIDFIRST_lazy(t)) {
2752 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2753 for (; isSPACE(*t); t++) ;
2754 if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
2756 "You need to quote \"%s\"", tmpbuf);
2762 PL_expect = XOPERATOR;
2763 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2764 bool islop = (PL_last_lop == PL_oldoldbufptr);
2765 if (!islop || PL_last_lop_op == OP_GREPSTART)
2766 PL_expect = XOPERATOR;
2767 else if (strchr("$@\"'`q", *s))
2768 PL_expect = XTERM; /* e.g. print $fh "foo" */
2769 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2770 PL_expect = XTERM; /* e.g. print $fh &sub */
2771 else if (isIDFIRST_lazy(s)) {
2772 char tmpbuf[sizeof PL_tokenbuf];
2773 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2774 if (tmp = keyword(tmpbuf, len)) {
2775 /* binary operators exclude handle interpretations */
2787 PL_expect = XTERM; /* e.g. print $fh length() */
2792 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2793 if (gv && GvCVu(gv))
2794 PL_expect = XTERM; /* e.g. print $fh subr() */
2797 else if (isDIGIT(*s))
2798 PL_expect = XTERM; /* e.g. print $fh 3 */
2799 else if (*s == '.' && isDIGIT(s[1]))
2800 PL_expect = XTERM; /* e.g. print $fh .3 */
2801 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2802 PL_expect = XTERM; /* e.g. print $fh -1 */
2803 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2804 PL_expect = XTERM; /* print $fh <<"EOF" */
2806 PL_pending_ident = '$';
2810 if (PL_expect == XOPERATOR)
2812 PL_tokenbuf[0] = '@';
2813 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2814 if (!PL_tokenbuf[1]) {
2816 yyerror("Final @ should be \\@ or @name");
2819 if (PL_lex_state == LEX_NORMAL)
2821 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2823 PL_tokenbuf[0] = '%';
2825 /* Warn about @ where they meant $. */
2826 if (ckWARN(WARN_SYNTAX)) {
2827 if (*s == '[' || *s == '{') {
2829 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2831 if (*t == '}' || *t == ']') {
2833 PL_bufptr = skipspace(PL_bufptr);
2835 "Scalar value %.*s better written as $%.*s",
2836 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2841 PL_pending_ident = '@';
2844 case '/': /* may either be division or pattern */
2845 case '?': /* may either be conditional or pattern */
2846 if (PL_expect != XOPERATOR) {
2847 /* Disable warning on "study /blah/" */
2848 if (PL_oldoldbufptr == PL_last_uni
2849 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2850 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2852 s = scan_pat(s,OP_MATCH);
2853 TERM(sublex_start());
2861 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2862 #ifdef PERL_STRICT_CR
2865 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2867 && (s == PL_linestart || s[-1] == '\n') )
2869 PL_lex_formbrack = 0;
2873 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2879 yylval.ival = OPf_SPECIAL;
2885 if (PL_expect != XOPERATOR)
2890 case '0': case '1': case '2': case '3': case '4':
2891 case '5': case '6': case '7': case '8': case '9':
2893 if (PL_expect == XOPERATOR)
2899 if (PL_expect == XOPERATOR) {
2900 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2903 return ','; /* grandfather non-comma-format format */
2909 missingterm((char*)0);
2910 yylval.ival = OP_CONST;
2911 TERM(sublex_start());
2915 if (PL_expect == XOPERATOR) {
2916 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2919 return ','; /* grandfather non-comma-format format */
2925 missingterm((char*)0);
2926 yylval.ival = OP_CONST;
2927 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2928 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2929 yylval.ival = OP_STRINGIFY;
2933 TERM(sublex_start());
2937 if (PL_expect == XOPERATOR)
2938 no_op("Backticks",s);
2940 missingterm((char*)0);
2941 yylval.ival = OP_BACKTICK;
2943 TERM(sublex_start());
2947 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2948 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2950 if (PL_expect == XOPERATOR)
2951 no_op("Backslash",s);
2955 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2995 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2997 /* Some keywords can be followed by any delimiter, including ':' */
2998 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2999 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3000 (PL_tokenbuf[0] == 'q' &&
3001 strchr("qwxr", PL_tokenbuf[1]))));
3003 /* x::* is just a word, unless x is "CORE" */
3004 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3008 while (d < PL_bufend && isSPACE(*d))
3009 d++; /* no comments skipped here, or s### is misparsed */
3011 /* Is this a label? */
3012 if (!tmp && PL_expect == XSTATE
3013 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3015 yylval.pval = savepv(PL_tokenbuf);
3020 /* Check for keywords */
3021 tmp = keyword(PL_tokenbuf, len);
3023 /* Is this a word before a => operator? */
3024 if (strnEQ(d,"=>",2)) {
3026 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3027 yylval.opval->op_private = OPpCONST_BARE;
3031 if (tmp < 0) { /* second-class keyword? */
3032 GV *ogv = Nullgv; /* override (winner) */
3033 GV *hgv = Nullgv; /* hidden (loser) */
3034 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3036 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3039 if (GvIMPORTED_CV(gv))
3041 else if (! CvMETHOD(cv))
3045 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3046 (gv = *gvp) != (GV*)&PL_sv_undef &&
3047 GvCVu(gv) && GvIMPORTED_CV(gv))
3053 tmp = 0; /* overridden by import or by GLOBAL */
3056 && -tmp==KEY_lock /* XXX generalizable kludge */
3057 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3059 tmp = 0; /* any sub overrides "weak" keyword */
3061 else { /* no override */
3065 if (ckWARN(WARN_AMBIGUOUS) && hgv
3066 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3067 warner(WARN_AMBIGUOUS,
3068 "Ambiguous call resolved as CORE::%s(), %s",
3069 GvENAME(hgv), "qualify as such or use &");
3076 default: /* not a keyword */
3079 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3081 /* Get the rest if it looks like a package qualifier */
3083 if (*s == '\'' || *s == ':' && s[1] == ':') {
3085 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3088 croak("Bad name after %s%s", PL_tokenbuf,
3089 *s == '\'' ? "'" : "::");
3093 if (PL_expect == XOPERATOR) {
3094 if (PL_bufptr == PL_linestart) {
3095 PL_curcop->cop_line--;
3096 warner(WARN_SEMICOLON, PL_warn_nosemi);
3097 PL_curcop->cop_line++;
3100 no_op("Bareword",s);
3103 /* Look for a subroutine with this name in current package,
3104 unless name is "Foo::", in which case Foo is a bearword
3105 (and a package name). */
3108 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3110 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3112 "Bareword \"%s\" refers to nonexistent package",
3115 PL_tokenbuf[len] = '\0';
3122 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3125 /* if we saw a global override before, get the right name */
3128 sv = newSVpv("CORE::GLOBAL::",14);
3129 sv_catpv(sv,PL_tokenbuf);
3132 sv = newSVpv(PL_tokenbuf,0);
3134 /* Presume this is going to be a bareword of some sort. */
3137 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3138 yylval.opval->op_private = OPpCONST_BARE;
3140 /* And if "Foo::", then that's what it certainly is. */
3145 /* See if it's the indirect object for a list operator. */
3147 if (PL_oldoldbufptr &&
3148 PL_oldoldbufptr < PL_bufptr &&
3149 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3150 /* NO SKIPSPACE BEFORE HERE! */
3152 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3153 || (PL_last_lop_op == OP_ENTERSUB
3155 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3157 bool immediate_paren = *s == '(';
3159 /* (Now we can afford to cross potential line boundary.) */
3162 /* Two barewords in a row may indicate method call. */
3164 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3167 /* If not a declared subroutine, it's an indirect object. */
3168 /* (But it's an indir obj regardless for sort.) */
3170 if ((PL_last_lop_op == OP_SORT ||
3171 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3172 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3173 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3178 /* If followed by a paren, it's certainly a subroutine. */
3180 PL_expect = XOPERATOR;
3184 if (gv && GvCVu(gv)) {
3186 if ((cv = GvCV(gv)) && SvPOK(cv))
3187 PL_last_proto = SvPV((SV*)cv, n_a);
3188 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3189 if (*d == ')' && (sv = cv_const_sv(cv))) {
3194 PL_nextval[PL_nexttoke].opval = yylval.opval;
3195 PL_expect = XOPERATOR;
3198 PL_last_lop_op = OP_ENTERSUB;
3202 /* If followed by var or block, call it a method (unless sub) */
3204 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3205 PL_last_lop = PL_oldbufptr;
3206 PL_last_lop_op = OP_METHOD;
3210 /* If followed by a bareword, see if it looks like indir obj. */
3212 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3215 /* Not a method, so call it a subroutine (if defined) */
3217 if (gv && GvCVu(gv)) {
3219 if (lastchar == '-')
3220 warn("Ambiguous use of -%s resolved as -&%s()",
3221 PL_tokenbuf, PL_tokenbuf);
3222 PL_last_lop = PL_oldbufptr;
3223 PL_last_lop_op = OP_ENTERSUB;
3224 /* Check for a constant sub */
3226 if ((sv = cv_const_sv(cv))) {
3228 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3229 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3230 yylval.opval->op_private = 0;
3234 /* Resolve to GV now. */
3235 op_free(yylval.opval);
3236 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3237 PL_last_lop_op = OP_ENTERSUB;
3238 /* Is there a prototype? */
3241 PL_last_proto = SvPV((SV*)cv, len);
3244 if (strEQ(PL_last_proto, "$"))
3246 if (*PL_last_proto == '&' && *s == '{') {
3247 sv_setpv(PL_subname,"__ANON__");
3251 PL_last_proto = NULL;
3252 PL_nextval[PL_nexttoke].opval = yylval.opval;
3258 if (PL_hints & HINT_STRICT_SUBS &&
3261 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3262 PL_last_lop_op != OP_ACCEPT &&
3263 PL_last_lop_op != OP_PIPE_OP &&
3264 PL_last_lop_op != OP_SOCKPAIR &&
3265 !(PL_last_lop_op == OP_ENTERSUB
3267 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3270 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3275 /* Call it a bare word */
3278 if (ckWARN(WARN_RESERVED)) {
3279 if (lastchar != '-') {
3280 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3282 warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
3287 if (lastchar && strchr("*%&", lastchar)) {
3288 warn("Operator or semicolon missing before %c%s",
3289 lastchar, PL_tokenbuf);
3290 warn("Ambiguous use of %c resolved as operator %c",
3291 lastchar, lastchar);
3297 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3298 newSVsv(GvSV(PL_curcop->cop_filegv)));
3302 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3303 newSVpvf("%ld", (long)PL_curcop->cop_line));
3306 case KEY___PACKAGE__:
3307 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3309 ? newSVsv(PL_curstname)
3318 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3319 char *pname = "main";
3320 if (PL_tokenbuf[2] == 'D')
3321 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3322 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3325 GvIOp(gv) = newIO();
3326 IoIFP(GvIOp(gv)) = PL_rsfp;
3327 #if defined(HAS_FCNTL) && defined(F_SETFD)
3329 int fd = PerlIO_fileno(PL_rsfp);
3330 fcntl(fd,F_SETFD,fd >= 3);
3333 /* Mark this internal pseudo-handle as clean */
3334 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3336 IoTYPE(GvIOp(gv)) = '|';
3337 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3338 IoTYPE(GvIOp(gv)) = '-';
3340 IoTYPE(GvIOp(gv)) = '<';
3351 if (PL_expect == XSTATE) {
3358 if (*s == ':' && s[1] == ':') {
3361 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3362 tmp = keyword(PL_tokenbuf, len);
3376 LOP(OP_ACCEPT,XTERM);
3382 LOP(OP_ATAN2,XTERM);
3391 LOP(OP_BLESS,XTERM);
3400 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3417 if (!PL_cryptseen++)
3420 LOP(OP_CRYPT,XTERM);
3423 if (ckWARN(WARN_OCTAL)) {
3424 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3425 if (*d != '0' && isDIGIT(*d))
3426 yywarn("chmod: mode argument is missing initial 0");
3428 LOP(OP_CHMOD,XTERM);
3431 LOP(OP_CHOWN,XTERM);
3434 LOP(OP_CONNECT,XTERM);
3450 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3454 PL_hints |= HINT_BLOCK_SCOPE;
3464 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3465 LOP(OP_DBMOPEN,XTERM);
3471 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3478 yylval.ival = PL_curcop->cop_line;
3492 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3493 UNIBRACK(OP_ENTEREVAL);
3508 case KEY_endhostent:
3514 case KEY_endservent:
3517 case KEY_endprotoent:
3528 yylval.ival = PL_curcop->cop_line;
3530 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3532 if ((PL_bufend - p) >= 3 &&
3533 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3536 if (isIDFIRST_lazy(p))
3537 croak("Missing $ on loop variable");
3542 LOP(OP_FORMLINE,XTERM);
3548 LOP(OP_FCNTL,XTERM);
3554 LOP(OP_FLOCK,XTERM);
3563 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3566 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3581 case KEY_getpriority:
3582 LOP(OP_GETPRIORITY,XTERM);
3584 case KEY_getprotobyname:
3587 case KEY_getprotobynumber:
3588 LOP(OP_GPBYNUMBER,XTERM);
3590 case KEY_getprotoent:
3602 case KEY_getpeername:
3603 UNI(OP_GETPEERNAME);
3605 case KEY_gethostbyname:
3608 case KEY_gethostbyaddr:
3609 LOP(OP_GHBYADDR,XTERM);
3611 case KEY_gethostent:
3614 case KEY_getnetbyname:
3617 case KEY_getnetbyaddr:
3618 LOP(OP_GNBYADDR,XTERM);
3623 case KEY_getservbyname:
3624 LOP(OP_GSBYNAME,XTERM);
3626 case KEY_getservbyport:
3627 LOP(OP_GSBYPORT,XTERM);
3629 case KEY_getservent:
3632 case KEY_getsockname:
3633 UNI(OP_GETSOCKNAME);
3635 case KEY_getsockopt:
3636 LOP(OP_GSOCKOPT,XTERM);
3658 yylval.ival = PL_curcop->cop_line;
3662 LOP(OP_INDEX,XTERM);
3668 LOP(OP_IOCTL,XTERM);
3680 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3711 LOP(OP_LISTEN,XTERM);
3720 s = scan_pat(s,OP_MATCH);
3721 TERM(sublex_start());
3724 LOP(OP_MAPSTART, XREF);
3727 LOP(OP_MKDIR,XTERM);
3730 LOP(OP_MSGCTL,XTERM);
3733 LOP(OP_MSGGET,XTERM);
3736 LOP(OP_MSGRCV,XTERM);
3739 LOP(OP_MSGSND,XTERM);
3744 if (isIDFIRST_lazy(s)) {
3745 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3746 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3747 if (!PL_in_my_stash) {
3750 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3757 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3764 if (PL_expect != XSTATE)
3765 yyerror("\"no\" not allowed in expression");
3766 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3767 s = force_version(s);
3776 if (isIDFIRST_lazy(s)) {
3778 for (d = s; isALNUM_lazy(d); d++) ;
3780 if (strchr("|&*+-=!?:.", *t))
3781 warn("Precedence problem: open %.*s should be open(%.*s)",
3787 yylval.ival = OP_OR;
3797 LOP(OP_OPEN_DIR,XTERM);
3800 checkcomma(s,PL_tokenbuf,"filehandle");
3804 checkcomma(s,PL_tokenbuf,"filehandle");
3823 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3827 LOP(OP_PIPE_OP,XTERM);
3832 missingterm((char*)0);
3833 yylval.ival = OP_CONST;
3834 TERM(sublex_start());
3842 missingterm((char*)0);
3843 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3844 d = SvPV_force(PL_lex_stuff, len);
3845 for (; len; --len, ++d) {
3848 "Possible attempt to separate words with commas");
3853 "Possible attempt to put comments in qw() list");
3859 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3860 PL_lex_stuff = Nullsv;
3863 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3866 yylval.ival = OP_SPLIT;
3870 PL_last_lop = PL_oldbufptr;
3871 PL_last_lop_op = OP_SPLIT;
3877 missingterm((char*)0);
3878 yylval.ival = OP_STRINGIFY;
3879 if (SvIVX(PL_lex_stuff) == '\'')
3880 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3881 TERM(sublex_start());
3884 s = scan_pat(s,OP_QR);
3885 TERM(sublex_start());
3890 missingterm((char*)0);
3891 yylval.ival = OP_BACKTICK;
3893 TERM(sublex_start());
3899 *PL_tokenbuf = '\0';
3900 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3901 if (isIDFIRST_lazy(PL_tokenbuf))
3902 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3904 yyerror("<> should be quotes");
3911 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3915 LOP(OP_RENAME,XTERM);
3924 LOP(OP_RINDEX,XTERM);
3947 LOP(OP_REVERSE,XTERM);
3958 TERM(sublex_start());
3960 TOKEN(1); /* force error */
3969 LOP(OP_SELECT,XTERM);
3975 LOP(OP_SEMCTL,XTERM);
3978 LOP(OP_SEMGET,XTERM);
3981 LOP(OP_SEMOP,XTERM);
3987 LOP(OP_SETPGRP,XTERM);
3989 case KEY_setpriority:
3990 LOP(OP_SETPRIORITY,XTERM);
3992 case KEY_sethostent:
3998 case KEY_setservent:
4001 case KEY_setprotoent:
4011 LOP(OP_SEEKDIR,XTERM);
4013 case KEY_setsockopt:
4014 LOP(OP_SSOCKOPT,XTERM);
4020 LOP(OP_SHMCTL,XTERM);
4023 LOP(OP_SHMGET,XTERM);
4026 LOP(OP_SHMREAD,XTERM);
4029 LOP(OP_SHMWRITE,XTERM);
4032 LOP(OP_SHUTDOWN,XTERM);
4041 LOP(OP_SOCKET,XTERM);
4043 case KEY_socketpair:
4044 LOP(OP_SOCKPAIR,XTERM);
4047 checkcomma(s,PL_tokenbuf,"subroutine name");
4049 if (*s == ';' || *s == ')') /* probably a close */
4050 croak("sort is now a reserved word");
4052 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4056 LOP(OP_SPLIT,XTERM);
4059 LOP(OP_SPRINTF,XTERM);
4062 LOP(OP_SPLICE,XTERM);
4078 LOP(OP_SUBSTR,XTERM);
4085 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4086 char tmpbuf[sizeof PL_tokenbuf];
4088 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4089 if (strchr(tmpbuf, ':'))
4090 sv_setpv(PL_subname, tmpbuf);
4092 sv_setsv(PL_subname,PL_curstname);
4093 sv_catpvn(PL_subname,"::",2);
4094 sv_catpvn(PL_subname,tmpbuf,len);
4096 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4100 PL_expect = XTERMBLOCK;
4101 sv_setpv(PL_subname,"?");
4104 if (tmp == KEY_format) {
4107 PL_lex_formbrack = PL_lex_brackets + 1;
4111 /* Look for a prototype */
4118 SvREFCNT_dec(PL_lex_stuff);
4119 PL_lex_stuff = Nullsv;
4120 croak("Prototype not terminated");
4123 d = SvPVX(PL_lex_stuff);
4125 for (p = d; *p; ++p) {
4130 SvCUR(PL_lex_stuff) = tmp;
4133 PL_nextval[1] = PL_nextval[0];
4134 PL_nexttype[1] = PL_nexttype[0];
4135 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4136 PL_nexttype[0] = THING;
4137 if (PL_nexttoke == 1) {
4138 PL_lex_defer = PL_lex_state;
4139 PL_lex_expect = PL_expect;
4140 PL_lex_state = LEX_KNOWNEXT;
4142 PL_lex_stuff = Nullsv;
4145 if (*SvPV(PL_subname,n_a) == '?') {
4146 sv_setpv(PL_subname,"__ANON__");
4153 LOP(OP_SYSTEM,XREF);
4156 LOP(OP_SYMLINK,XTERM);
4159 LOP(OP_SYSCALL,XTERM);
4162 LOP(OP_SYSOPEN,XTERM);
4165 LOP(OP_SYSSEEK,XTERM);
4168 LOP(OP_SYSREAD,XTERM);
4171 LOP(OP_SYSWRITE,XTERM);
4175 TERM(sublex_start());
4196 LOP(OP_TRUNCATE,XTERM);
4208 yylval.ival = PL_curcop->cop_line;
4212 yylval.ival = PL_curcop->cop_line;
4216 LOP(OP_UNLINK,XTERM);
4222 LOP(OP_UNPACK,XTERM);
4225 LOP(OP_UTIME,XTERM);
4228 if (ckWARN(WARN_OCTAL)) {
4229 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4230 if (*d != '0' && isDIGIT(*d))
4231 yywarn("umask: argument is missing initial 0");
4236 LOP(OP_UNSHIFT,XTERM);
4239 if (PL_expect != XSTATE)
4240 yyerror("\"use\" not allowed in expression");
4243 s = force_version(s);
4244 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4245 PL_nextval[PL_nexttoke].opval = Nullop;
4250 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4251 s = force_version(s);
4264 yylval.ival = PL_curcop->cop_line;
4268 PL_hints |= HINT_BLOCK_SCOPE;
4275 LOP(OP_WAITPID,XTERM);
4283 static char ctl_l[2];
4285 if (ctl_l[0] == '\0')
4286 ctl_l[0] = toCTRL('L');
4287 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4290 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4295 if (PL_expect == XOPERATOR)
4301 yylval.ival = OP_XOR;
4306 TERM(sublex_start());
4312 keyword(register char *d, I32 len)
4317 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4318 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4319 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4320 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4321 if (strEQ(d,"__END__")) return KEY___END__;
4325 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4330 if (strEQ(d,"and")) return -KEY_and;
4331 if (strEQ(d,"abs")) return -KEY_abs;
4334 if (strEQ(d,"alarm")) return -KEY_alarm;
4335 if (strEQ(d,"atan2")) return -KEY_atan2;
4338 if (strEQ(d,"accept")) return -KEY_accept;
4343 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4346 if (strEQ(d,"bless")) return -KEY_bless;
4347 if (strEQ(d,"bind")) return -KEY_bind;
4348 if (strEQ(d,"binmode")) return -KEY_binmode;
4351 if (strEQ(d,"CORE")) return -KEY_CORE;
4356 if (strEQ(d,"cmp")) return -KEY_cmp;
4357 if (strEQ(d,"chr")) return -KEY_chr;
4358 if (strEQ(d,"cos")) return -KEY_cos;
4361 if (strEQ(d,"chop")) return KEY_chop;
4364 if (strEQ(d,"close")) return -KEY_close;
4365 if (strEQ(d,"chdir")) return -KEY_chdir;
4366 if (strEQ(d,"chomp")) return KEY_chomp;
4367 if (strEQ(d,"chmod")) return -KEY_chmod;
4368 if (strEQ(d,"chown")) return -KEY_chown;
4369 if (strEQ(d,"crypt")) return -KEY_crypt;
4372 if (strEQ(d,"chroot")) return -KEY_chroot;
4373 if (strEQ(d,"caller")) return -KEY_caller;
4376 if (strEQ(d,"connect")) return -KEY_connect;
4379 if (strEQ(d,"closedir")) return -KEY_closedir;
4380 if (strEQ(d,"continue")) return -KEY_continue;
4385 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4390 if (strEQ(d,"do")) return KEY_do;
4393 if (strEQ(d,"die")) return -KEY_die;
4396 if (strEQ(d,"dump")) return -KEY_dump;
4399 if (strEQ(d,"delete")) return KEY_delete;
4402 if (strEQ(d,"defined")) return KEY_defined;
4403 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4406 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4411 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4412 if (strEQ(d,"END")) return KEY_END;
4417 if (strEQ(d,"eq")) return -KEY_eq;
4420 if (strEQ(d,"eof")) return -KEY_eof;
4421 if (strEQ(d,"exp")) return -KEY_exp;
4424 if (strEQ(d,"else")) return KEY_else;
4425 if (strEQ(d,"exit")) return -KEY_exit;
4426 if (strEQ(d,"eval")) return KEY_eval;
4427 if (strEQ(d,"exec")) return -KEY_exec;
4428 if (strEQ(d,"each")) return KEY_each;
4431 if (strEQ(d,"elsif")) return KEY_elsif;
4434 if (strEQ(d,"exists")) return KEY_exists;
4435 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4438 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4439 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4442 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4445 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4446 if (strEQ(d,"endservent")) return -KEY_endservent;
4449 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4456 if (strEQ(d,"for")) return KEY_for;
4459 if (strEQ(d,"fork")) return -KEY_fork;
4462 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4463 if (strEQ(d,"flock")) return -KEY_flock;
4466 if (strEQ(d,"format")) return KEY_format;
4467 if (strEQ(d,"fileno")) return -KEY_fileno;
4470 if (strEQ(d,"foreach")) return KEY_foreach;
4473 if (strEQ(d,"formline")) return -KEY_formline;
4479 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4480 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4484 if (strnEQ(d,"get",3)) {
4489 if (strEQ(d,"ppid")) return -KEY_getppid;
4490 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4493 if (strEQ(d,"pwent")) return -KEY_getpwent;
4494 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4495 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4498 if (strEQ(d,"peername")) return -KEY_getpeername;
4499 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4500 if (strEQ(d,"priority")) return -KEY_getpriority;
4503 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4506 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4510 else if (*d == 'h') {
4511 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4512 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4513 if (strEQ(d,"hostent")) return -KEY_gethostent;
4515 else if (*d == 'n') {
4516 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4517 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4518 if (strEQ(d,"netent")) return -KEY_getnetent;
4520 else if (*d == 's') {
4521 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4522 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4523 if (strEQ(d,"servent")) return -KEY_getservent;
4524 if (strEQ(d,"sockname")) return -KEY_getsockname;
4525 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4527 else if (*d == 'g') {
4528 if (strEQ(d,"grent")) return -KEY_getgrent;
4529 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4530 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4532 else if (*d == 'l') {
4533 if (strEQ(d,"login")) return -KEY_getlogin;
4535 else if (strEQ(d,"c")) return -KEY_getc;
4540 if (strEQ(d,"gt")) return -KEY_gt;
4541 if (strEQ(d,"ge")) return -KEY_ge;
4544 if (strEQ(d,"grep")) return KEY_grep;
4545 if (strEQ(d,"goto")) return KEY_goto;
4546 if (strEQ(d,"glob")) return KEY_glob;
4549 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4554 if (strEQ(d,"hex")) return -KEY_hex;
4557 if (strEQ(d,"INIT")) return KEY_INIT;
4562 if (strEQ(d,"if")) return KEY_if;
4565 if (strEQ(d,"int")) return -KEY_int;
4568 if (strEQ(d,"index")) return -KEY_index;
4569 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4574 if (strEQ(d,"join")) return -KEY_join;
4578 if (strEQ(d,"keys")) return KEY_keys;
4579 if (strEQ(d,"kill")) return -KEY_kill;
4584 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4585 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4591 if (strEQ(d,"lt")) return -KEY_lt;
4592 if (strEQ(d,"le")) return -KEY_le;
4593 if (strEQ(d,"lc")) return -KEY_lc;
4596 if (strEQ(d,"log")) return -KEY_log;
4599 if (strEQ(d,"last")) return KEY_last;
4600 if (strEQ(d,"link")) return -KEY_link;
4601 if (strEQ(d,"lock")) return -KEY_lock;
4604 if (strEQ(d,"local")) return KEY_local;
4605 if (strEQ(d,"lstat")) return -KEY_lstat;
4608 if (strEQ(d,"length")) return -KEY_length;
4609 if (strEQ(d,"listen")) return -KEY_listen;
4612 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4615 if (strEQ(d,"localtime")) return -KEY_localtime;
4621 case 1: return KEY_m;
4623 if (strEQ(d,"my")) return KEY_my;
4626 if (strEQ(d,"map")) return KEY_map;
4629 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4632 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4633 if (strEQ(d,"msgget")) return -KEY_msgget;
4634 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4635 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4640 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4643 if (strEQ(d,"next")) return KEY_next;
4644 if (strEQ(d,"ne")) return -KEY_ne;
4645 if (strEQ(d,"not")) return -KEY_not;
4646 if (strEQ(d,"no")) return KEY_no;
4651 if (strEQ(d,"or")) return -KEY_or;
4654 if (strEQ(d,"ord")) return -KEY_ord;
4655 if (strEQ(d,"oct")) return -KEY_oct;
4656 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4660 if (strEQ(d,"open")) return -KEY_open;
4663 if (strEQ(d,"opendir")) return -KEY_opendir;
4670 if (strEQ(d,"pop")) return KEY_pop;
4671 if (strEQ(d,"pos")) return KEY_pos;
4674 if (strEQ(d,"push")) return KEY_push;
4675 if (strEQ(d,"pack")) return -KEY_pack;
4676 if (strEQ(d,"pipe")) return -KEY_pipe;
4679 if (strEQ(d,"print")) return KEY_print;
4682 if (strEQ(d,"printf")) return KEY_printf;
4685 if (strEQ(d,"package")) return KEY_package;
4688 if (strEQ(d,"prototype")) return KEY_prototype;
4693 if (strEQ(d,"q")) return KEY_q;
4694 if (strEQ(d,"qr")) return KEY_qr;
4695 if (strEQ(d,"qq")) return KEY_qq;
4696 if (strEQ(d,"qw")) return KEY_qw;
4697 if (strEQ(d,"qx")) return KEY_qx;
4699 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4704 if (strEQ(d,"ref")) return -KEY_ref;
4707 if (strEQ(d,"read")) return -KEY_read;
4708 if (strEQ(d,"rand")) return -KEY_rand;
4709 if (strEQ(d,"recv")) return -KEY_recv;
4710 if (strEQ(d,"redo")) return KEY_redo;
4713 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4714 if (strEQ(d,"reset")) return -KEY_reset;
4717 if (strEQ(d,"return")) return KEY_return;
4718 if (strEQ(d,"rename")) return -KEY_rename;
4719 if (strEQ(d,"rindex")) return -KEY_rindex;
4722 if (strEQ(d,"require")) return -KEY_require;
4723 if (strEQ(d,"reverse")) return -KEY_reverse;
4724 if (strEQ(d,"readdir")) return -KEY_readdir;
4727 if (strEQ(d,"readlink")) return -KEY_readlink;
4728 if (strEQ(d,"readline")) return -KEY_readline;
4729 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4732 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4738 case 0: return KEY_s;
4740 if (strEQ(d,"scalar")) return KEY_scalar;
4745 if (strEQ(d,"seek")) return -KEY_seek;
4746 if (strEQ(d,"send")) return -KEY_send;
4749 if (strEQ(d,"semop")) return -KEY_semop;
4752 if (strEQ(d,"select")) return -KEY_select;
4753 if (strEQ(d,"semctl")) return -KEY_semctl;
4754 if (strEQ(d,"semget")) return -KEY_semget;
4757 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4758 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4761 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4762 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4765 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4768 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4769 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4770 if (strEQ(d,"setservent")) return -KEY_setservent;
4773 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4774 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4781 if (strEQ(d,"shift")) return KEY_shift;
4784 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4785 if (strEQ(d,"shmget")) return -KEY_shmget;
4788 if (strEQ(d,"shmread")) return -KEY_shmread;
4791 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4792 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4797 if (strEQ(d,"sin")) return -KEY_sin;
4800 if (strEQ(d,"sleep")) return -KEY_sleep;
4803 if (strEQ(d,"sort")) return KEY_sort;
4804 if (strEQ(d,"socket")) return -KEY_socket;
4805 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4808 if (strEQ(d,"split")) return KEY_split;
4809 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4810 if (strEQ(d,"splice")) return KEY_splice;
4813 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4816 if (strEQ(d,"srand")) return -KEY_srand;
4819 if (strEQ(d,"stat")) return -KEY_stat;
4820 if (strEQ(d,"study")) return KEY_study;
4823 if (strEQ(d,"substr")) return -KEY_substr;
4824 if (strEQ(d,"sub")) return KEY_sub;
4829 if (strEQ(d,"system")) return -KEY_system;
4832 if (strEQ(d,"symlink")) return -KEY_symlink;
4833 if (strEQ(d,"syscall")) return -KEY_syscall;
4834 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4835 if (strEQ(d,"sysread")) return -KEY_sysread;
4836 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4839 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4848 if (strEQ(d,"tr")) return KEY_tr;
4851 if (strEQ(d,"tie")) return KEY_tie;
4854 if (strEQ(d,"tell")) return -KEY_tell;
4855 if (strEQ(d,"tied")) return KEY_tied;
4856 if (strEQ(d,"time")) return -KEY_time;
4859 if (strEQ(d,"times")) return -KEY_times;
4862 if (strEQ(d,"telldir")) return -KEY_telldir;
4865 if (strEQ(d,"truncate")) return -KEY_truncate;
4872 if (strEQ(d,"uc")) return -KEY_uc;
4875 if (strEQ(d,"use")) return KEY_use;
4878 if (strEQ(d,"undef")) return KEY_undef;
4879 if (strEQ(d,"until")) return KEY_until;
4880 if (strEQ(d,"untie")) return KEY_untie;
4881 if (strEQ(d,"utime")) return -KEY_utime;
4882 if (strEQ(d,"umask")) return -KEY_umask;
4885 if (strEQ(d,"unless")) return KEY_unless;
4886 if (strEQ(d,"unpack")) return -KEY_unpack;
4887 if (strEQ(d,"unlink")) return -KEY_unlink;
4890 if (strEQ(d,"unshift")) return KEY_unshift;
4891 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4896 if (strEQ(d,"values")) return -KEY_values;
4897 if (strEQ(d,"vec")) return -KEY_vec;
4902 if (strEQ(d,"warn")) return -KEY_warn;
4903 if (strEQ(d,"wait")) return -KEY_wait;
4906 if (strEQ(d,"while")) return KEY_while;
4907 if (strEQ(d,"write")) return -KEY_write;
4910 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4913 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4918 if (len == 1) return -KEY_x;
4919 if (strEQ(d,"xor")) return -KEY_xor;
4922 if (len == 1) return KEY_y;
4931 checkcomma(register char *s, char *name, char *what)
4935 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4936 dTHR; /* only for ckWARN */
4937 if (ckWARN(WARN_SYNTAX)) {
4939 for (w = s+2; *w && level; w++) {
4946 for (; *w && isSPACE(*w); w++) ;
4947 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4948 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4951 while (s < PL_bufend && isSPACE(*s))
4955 while (s < PL_bufend && isSPACE(*s))
4957 if (isIDFIRST_lazy(s)) {
4959 while (isALNUM_lazy(s))
4961 while (s < PL_bufend && isSPACE(*s))
4966 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4970 croak("No comma allowed after %s", what);
4976 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4979 HV *table = GvHV(PL_hintgv); /* ^H */
4982 bool oldcatch = CATCH_GET;
4987 yyerror("%^H is not defined");
4990 cvp = hv_fetch(table, key, strlen(key), FALSE);
4991 if (!cvp || !SvOK(*cvp)) {
4993 sprintf(buf,"$^H{%s} is not defined", key);
4997 sv_2mortal(sv); /* Parent created it permanently */
5000 pv = sv_2mortal(newSVpv(s, len));
5002 typesv = sv_2mortal(newSVpv(type, 0));
5004 typesv = &PL_sv_undef;
5006 Zero(&myop, 1, BINOP);
5007 myop.op_last = (OP *) &myop;
5008 myop.op_next = Nullop;
5009 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
5011 PUSHSTACKi(PERLSI_OVERLOAD);
5014 PL_op = (OP *) &myop;
5015 if (PERLDB_SUB && PL_curstash != PL_debstash)
5016 PL_op->op_private |= OPpENTERSUB_DB;
5027 if (PL_op = pp_entersub(ARGS))
5034 CATCH_SET(oldcatch);
5039 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5042 return SvREFCNT_inc(res);
5046 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5048 register char *d = dest;
5049 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5052 croak(ident_too_long);
5053 if (isALNUM(*s)) /* UTF handled below */
5055 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5060 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5064 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5065 char *t = s + UTF8SKIP(s);
5066 while (*t & 0x80 && is_utf8_mark((U8*)t))
5068 if (d + (t - s) > e)
5069 croak(ident_too_long);
5070 Copy(s, d, t - s, char);
5083 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5090 if (PL_lex_brackets == 0)
5091 PL_lex_fakebrack = 0;
5095 e = d + destlen - 3; /* two-character token, ending NUL */
5097 while (isDIGIT(*s)) {
5099 croak(ident_too_long);
5106 croak(ident_too_long);
5107 if (isALNUM(*s)) /* UTF handled below */
5109 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5114 else if (*s == ':' && s[1] == ':') {
5118 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5119 char *t = s + UTF8SKIP(s);
5120 while (*t & 0x80 && is_utf8_mark((U8*)t))
5122 if (d + (t - s) > e)
5123 croak(ident_too_long);
5124 Copy(s, d, t - s, char);
5135 if (PL_lex_state != LEX_NORMAL)
5136 PL_lex_state = LEX_INTERPENDMAYBE;
5139 if (*s == '$' && s[1] &&
5140 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5153 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5158 if (isSPACE(s[-1])) {
5161 if (ch != ' ' && ch != '\t') {
5167 if (isIDFIRST_lazy(d)) {
5171 while (e < send && isALNUM_lazy(e) || *e == ':') {
5173 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5176 Copy(s, d, e - s, char);
5181 while (isALNUM(*s) || *s == ':')
5185 while (s < send && (*s == ' ' || *s == '\t')) s++;
5186 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5187 dTHR; /* only for ckWARN */
5188 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5189 char *brack = *s == '[' ? "[...]" : "{...}";
5190 warner(WARN_AMBIGUOUS,
5191 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5192 funny, dest, brack, funny, dest, brack);
5194 PL_lex_fakebrack = PL_lex_brackets+1;
5196 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5202 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5203 PL_lex_state = LEX_INTERPEND;
5206 if (PL_lex_state == LEX_NORMAL) {
5207 dTHR; /* only for ckWARN */
5208 if (ckWARN(WARN_AMBIGUOUS) &&
5209 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5211 warner(WARN_AMBIGUOUS,
5212 "Ambiguous use of %c{%s} resolved to %c%s",
5213 funny, dest, funny, dest);
5218 s = bracket; /* let the parser handle it */
5222 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5223 PL_lex_state = LEX_INTERPEND;
5227 void pmflag(U16 *pmfl, int ch)
5232 *pmfl |= PMf_GLOBAL;
5234 *pmfl |= PMf_CONTINUE;
5238 *pmfl |= PMf_MULTILINE;
5240 *pmfl |= PMf_SINGLELINE;
5242 *pmfl |= PMf_EXTENDED;
5246 scan_pat(char *start, I32 type)
5251 s = scan_str(start);
5254 SvREFCNT_dec(PL_lex_stuff);
5255 PL_lex_stuff = Nullsv;
5256 croak("Search pattern not terminated");
5259 pm = (PMOP*)newPMOP(type, 0);
5260 if (PL_multi_open == '?')
5261 pm->op_pmflags |= PMf_ONCE;
5263 while (*s && strchr("iomsx", *s))
5264 pmflag(&pm->op_pmflags,*s++);
5267 while (*s && strchr("iogcmsx", *s))
5268 pmflag(&pm->op_pmflags,*s++);
5270 pm->op_pmpermflags = pm->op_pmflags;
5272 PL_lex_op = (OP*)pm;
5273 yylval.ival = OP_MATCH;
5278 scan_subst(char *start)
5285 yylval.ival = OP_NULL;
5287 s = scan_str(start);
5291 SvREFCNT_dec(PL_lex_stuff);
5292 PL_lex_stuff = Nullsv;
5293 croak("Substitution pattern not terminated");
5296 if (s[-1] == PL_multi_open)
5299 first_start = PL_multi_start;
5303 SvREFCNT_dec(PL_lex_stuff);
5304 PL_lex_stuff = Nullsv;
5306 SvREFCNT_dec(PL_lex_repl);
5307 PL_lex_repl = Nullsv;
5308 croak("Substitution replacement not terminated");
5310 PL_multi_start = first_start; /* so whole substitution is taken together */
5312 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5318 else if (strchr("iogcmsx", *s))
5319 pmflag(&pm->op_pmflags,*s++);
5326 pm->op_pmflags |= PMf_EVAL;
5327 repl = newSVpv("",0);
5329 sv_catpv(repl, es ? "eval " : "do ");
5330 sv_catpvn(repl, "{ ", 2);
5331 sv_catsv(repl, PL_lex_repl);
5332 sv_catpvn(repl, " };", 2);
5333 SvCOMPILED_on(repl);
5334 SvREFCNT_dec(PL_lex_repl);
5338 pm->op_pmpermflags = pm->op_pmflags;
5339 PL_lex_op = (OP*)pm;
5340 yylval.ival = OP_SUBST;
5345 scan_trans(char *start)
5356 yylval.ival = OP_NULL;
5358 s = scan_str(start);
5361 SvREFCNT_dec(PL_lex_stuff);
5362 PL_lex_stuff = Nullsv;
5363 croak("Transliteration pattern not terminated");
5365 if (s[-1] == PL_multi_open)
5371 SvREFCNT_dec(PL_lex_stuff);
5372 PL_lex_stuff = Nullsv;
5374 SvREFCNT_dec(PL_lex_repl);
5375 PL_lex_repl = Nullsv;
5376 croak("Transliteration replacement not terminated");
5380 o = newSVOP(OP_TRANS, 0, 0);
5381 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5384 New(803,tbl,256,short);
5385 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5389 complement = del = squash = 0;
5390 while (strchr("cdsCU", *s)) {
5392 complement = OPpTRANS_COMPLEMENT;
5394 del = OPpTRANS_DELETE;
5396 squash = OPpTRANS_SQUASH;
5401 utf8 &= ~OPpTRANS_FROM_UTF;
5403 utf8 |= OPpTRANS_FROM_UTF;
5407 utf8 &= ~OPpTRANS_TO_UTF;
5409 utf8 |= OPpTRANS_TO_UTF;
5412 croak("Too many /C and /U options");
5417 o->op_private = del|squash|complement|utf8;
5420 yylval.ival = OP_TRANS;
5425 scan_heredoc(register char *s)
5429 I32 op_type = OP_SCALAR;
5436 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5440 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5443 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5444 if (*peek && strchr("`'\"",*peek)) {
5447 s = delimcpy(d, e, s, PL_bufend, term, &len);
5457 if (!isALNUM_lazy(s))
5458 deprecate("bare << to mean <<\"\"");
5459 for (; isALNUM_lazy(s); s++) {
5464 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5465 croak("Delimiter for here document is too long");
5468 len = d - PL_tokenbuf;
5469 #ifndef PERL_STRICT_CR
5470 d = strchr(s, '\r');
5474 while (s < PL_bufend) {
5480 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5489 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5494 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5495 herewas = newSVpv(s,PL_bufend-s);
5497 s--, herewas = newSVpv(s,d-s);
5498 s += SvCUR(herewas);
5500 tmpstr = NEWSV(87,79);
5501 sv_upgrade(tmpstr, SVt_PVIV);
5506 else if (term == '`') {
5507 op_type = OP_BACKTICK;
5508 SvIVX(tmpstr) = '\\';
5512 PL_multi_start = PL_curcop->cop_line;
5513 PL_multi_open = PL_multi_close = '<';
5514 term = *PL_tokenbuf;
5517 while (s < PL_bufend &&
5518 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5520 PL_curcop->cop_line++;
5522 if (s >= PL_bufend) {
5523 PL_curcop->cop_line = PL_multi_start;
5524 missingterm(PL_tokenbuf);
5526 sv_setpvn(tmpstr,d+1,s-d);
5528 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5530 sv_catpvn(herewas,s,PL_bufend-s);
5531 sv_setsv(PL_linestr,herewas);
5532 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5533 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5536 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5537 while (s >= PL_bufend) { /* multiple line string? */
5539 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5540 PL_curcop->cop_line = PL_multi_start;
5541 missingterm(PL_tokenbuf);
5543 PL_curcop->cop_line++;
5544 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5545 #ifndef PERL_STRICT_CR
5546 if (PL_bufend - PL_linestart >= 2) {
5547 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5548 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5550 PL_bufend[-2] = '\n';
5552 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5554 else if (PL_bufend[-1] == '\r')
5555 PL_bufend[-1] = '\n';
5557 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5558 PL_bufend[-1] = '\n';
5560 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5561 SV *sv = NEWSV(88,0);
5563 sv_upgrade(sv, SVt_PVMG);
5564 sv_setsv(sv,PL_linestr);
5565 av_store(GvAV(PL_curcop->cop_filegv),
5566 (I32)PL_curcop->cop_line,sv);
5568 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5571 sv_catsv(PL_linestr,herewas);
5572 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5576 sv_catsv(tmpstr,PL_linestr);
5579 PL_multi_end = PL_curcop->cop_line;
5581 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5582 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5583 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5585 SvREFCNT_dec(herewas);
5586 PL_lex_stuff = tmpstr;
5587 yylval.ival = op_type;
5592 takes: current position in input buffer
5593 returns: new position in input buffer
5594 side-effects: yylval and lex_op are set.
5599 <FH> read from filehandle
5600 <pkg::FH> read from package qualified filehandle
5601 <pkg'FH> read from package qualified filehandle
5602 <$fh> read from filehandle in $fh
5608 scan_inputsymbol(char *start)
5610 register char *s = start; /* current position in buffer */
5615 d = PL_tokenbuf; /* start of temp holding space */
5616 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5617 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5619 /* die if we didn't have space for the contents of the <>,
5623 if (len >= sizeof PL_tokenbuf)
5624 croak("Excessively long <> operator");
5626 croak("Unterminated <> operator");
5631 Remember, only scalar variables are interpreted as filehandles by
5632 this code. Anything more complex (e.g., <$fh{$num}>) will be
5633 treated as a glob() call.
5634 This code makes use of the fact that except for the $ at the front,
5635 a scalar variable and a filehandle look the same.
5637 if (*d == '$' && d[1]) d++;
5639 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5640 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5643 /* If we've tried to read what we allow filehandles to look like, and
5644 there's still text left, then it must be a glob() and not a getline.
5645 Use scan_str to pull out the stuff between the <> and treat it
5646 as nothing more than a string.
5649 if (d - PL_tokenbuf != len) {
5650 yylval.ival = OP_GLOB;
5652 s = scan_str(start);
5654 croak("Glob not terminated");
5658 /* we're in a filehandle read situation */
5661 /* turn <> into <ARGV> */
5663 (void)strcpy(d,"ARGV");
5665 /* if <$fh>, create the ops to turn the variable into a
5671 /* try to find it in the pad for this block, otherwise find
5672 add symbol table ops
5674 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5675 OP *o = newOP(OP_PADSV, 0);
5677 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5680 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5681 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5682 newUNOP(OP_RV2SV, 0,
5683 newGVOP(OP_GV, 0, gv)));
5685 PL_lex_op->op_flags |= OPf_SPECIAL;
5686 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5687 yylval.ival = OP_NULL;
5690 /* If it's none of the above, it must be a literal filehandle
5691 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5693 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5694 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5695 yylval.ival = OP_NULL;
5704 takes: start position in buffer
5705 returns: position to continue reading from buffer
5706 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5707 updates the read buffer.
5709 This subroutine pulls a string out of the input. It is called for:
5710 q single quotes q(literal text)
5711 ' single quotes 'literal text'
5712 qq double quotes qq(interpolate $here please)
5713 " double quotes "interpolate $here please"
5714 qx backticks qx(/bin/ls -l)
5715 ` backticks `/bin/ls -l`
5716 qw quote words @EXPORT_OK = qw( func() $spam )
5717 m// regexp match m/this/
5718 s/// regexp substitute s/this/that/
5719 tr/// string transliterate tr/this/that/
5720 y/// string transliterate y/this/that/
5721 ($*@) sub prototypes sub foo ($)
5722 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5724 In most of these cases (all but <>, patterns and transliterate)
5725 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5726 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5727 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5730 It skips whitespace before the string starts, and treats the first
5731 character as the delimiter. If the delimiter is one of ([{< then
5732 the corresponding "close" character )]}> is used as the closing
5733 delimiter. It allows quoting of delimiters, and if the string has
5734 balanced delimiters ([{<>}]) it allows nesting.
5736 The lexer always reads these strings into lex_stuff, except in the
5737 case of the operators which take *two* arguments (s/// and tr///)
5738 when it checks to see if lex_stuff is full (presumably with the 1st
5739 arg to s or tr) and if so puts the string into lex_repl.
5744 scan_str(char *start)
5747 SV *sv; /* scalar value: string */
5748 char *tmps; /* temp string, used for delimiter matching */
5749 register char *s = start; /* current position in the buffer */
5750 register char term; /* terminating character */
5751 register char *to; /* current position in the sv's data */
5752 I32 brackets = 1; /* bracket nesting level */
5754 /* skip space before the delimiter */
5758 /* mark where we are, in case we need to report errors */
5761 /* after skipping whitespace, the next character is the terminator */
5763 /* mark where we are */
5764 PL_multi_start = PL_curcop->cop_line;
5765 PL_multi_open = term;
5767 /* find corresponding closing delimiter */
5768 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5770 PL_multi_close = term;
5772 /* create a new SV to hold the contents. 87 is leak category, I'm
5773 assuming. 79 is the SV's initial length. What a random number. */
5775 sv_upgrade(sv, SVt_PVIV);
5777 (void)SvPOK_only(sv); /* validate pointer */
5779 /* move past delimiter and try to read a complete string */
5782 /* extend sv if need be */
5783 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5784 /* set 'to' to the next character in the sv's string */
5785 to = SvPVX(sv)+SvCUR(sv);
5787 /* if open delimiter is the close delimiter read unbridle */
5788 if (PL_multi_open == PL_multi_close) {
5789 for (; s < PL_bufend; s++,to++) {
5790 /* embedded newlines increment the current line number */
5791 if (*s == '\n' && !PL_rsfp)
5792 PL_curcop->cop_line++;
5793 /* handle quoted delimiters */
5794 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5797 /* any other quotes are simply copied straight through */
5801 /* terminate when run out of buffer (the for() condition), or
5802 have found the terminator */
5803 else if (*s == term)
5809 /* if the terminator isn't the same as the start character (e.g.,
5810 matched brackets), we have to allow more in the quoting, and
5811 be prepared for nested brackets.
5814 /* read until we run out of string, or we find the terminator */
5815 for (; s < PL_bufend; s++,to++) {
5816 /* embedded newlines increment the line count */
5817 if (*s == '\n' && !PL_rsfp)
5818 PL_curcop->cop_line++;
5819 /* backslashes can escape the open or closing characters */
5820 if (*s == '\\' && s+1 < PL_bufend) {
5821 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5826 /* allow nested opens and closes */
5827 else if (*s == PL_multi_close && --brackets <= 0)
5829 else if (*s == PL_multi_open)
5834 /* terminate the copied string and update the sv's end-of-string */
5836 SvCUR_set(sv, to - SvPVX(sv));
5839 * this next chunk reads more into the buffer if we're not done yet
5842 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5844 #ifndef PERL_STRICT_CR
5845 if (to - SvPVX(sv) >= 2) {
5846 if ((to[-2] == '\r' && to[-1] == '\n') ||
5847 (to[-2] == '\n' && to[-1] == '\r'))
5851 SvCUR_set(sv, to - SvPVX(sv));
5853 else if (to[-1] == '\r')
5856 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5860 /* if we're out of file, or a read fails, bail and reset the current
5861 line marker so we can report where the unterminated string began
5864 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5866 PL_curcop->cop_line = PL_multi_start;
5869 /* we read a line, so increment our line counter */
5870 PL_curcop->cop_line++;
5872 /* update debugger info */
5873 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5874 SV *sv = NEWSV(88,0);
5876 sv_upgrade(sv, SVt_PVMG);
5877 sv_setsv(sv,PL_linestr);
5878 av_store(GvAV(PL_curcop->cop_filegv),
5879 (I32)PL_curcop->cop_line, sv);
5882 /* having changed the buffer, we must update PL_bufend */
5883 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5886 /* at this point, we have successfully read the delimited string */
5888 PL_multi_end = PL_curcop->cop_line;
5891 /* if we allocated too much space, give some back */
5892 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5893 SvLEN_set(sv, SvCUR(sv) + 1);
5894 Renew(SvPVX(sv), SvLEN(sv), char);
5897 /* decide whether this is the first or second quoted string we've read
5910 takes: pointer to position in buffer
5911 returns: pointer to new position in buffer
5912 side-effects: builds ops for the constant in yylval.op
5914 Read a number in any of the formats that Perl accepts:
5916 0(x[0-7A-F]+)|([0-7]+)|(b[01])
5917 [\d_]+(\.[\d_]*)?[Ee](\d+)
5919 Underbars (_) are allowed in decimal numbers. If -w is on,
5920 underbars before a decimal point must be at three digit intervals.
5922 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5925 If it reads a number without a decimal point or an exponent, it will
5926 try converting the number to an integer and see if it can do so
5927 without loss of precision.
5931 scan_num(char *start)
5933 register char *s = start; /* current position in buffer */
5934 register char *d; /* destination in temp buffer */
5935 register char *e; /* end of temp buffer */
5936 I32 tryiv; /* used to see if it can be an int */
5937 double value; /* number read, as a double */
5938 SV *sv; /* place to put the converted number */
5939 I32 floatit; /* boolean: int or float? */
5940 char *lastub = 0; /* position of last underbar */
5941 static char number_too_long[] = "Number too long";
5943 /* We use the first character to decide what type of number this is */
5947 croak("panic: scan_num");
5949 /* if it starts with a 0, it could be an octal number, a decimal in
5950 0.13 disguise, or a hexadecimal number, or a binary number.
5955 u holds the "number so far"
5956 shift the power of 2 of the base
5957 (hex == 4, octal == 3, binary == 1)
5958 overflowed was the number more than we can hold?
5960 Shift is used when we add a digit. It also serves as an "are
5961 we in octal/hex/binary?" indicator to disallow hex characters
5966 bool overflowed = FALSE;
5972 } else if (s[1] == 'b') {
5976 /* check for a decimal in disguise */
5977 else if (s[1] == '.')
5979 /* so it must be octal */
5984 /* read the rest of the number */
5986 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5990 /* if we don't mention it, we're done */
5999 /* 8 and 9 are not octal */
6002 yyerror("Illegal octal digit");
6005 yyerror("Illegal binary digit");
6009 case '2': case '3': case '4':
6010 case '5': case '6': case '7':
6012 yyerror("Illegal binary digit");
6016 b = *s++ & 15; /* ASCII digit -> value of digit */
6020 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6021 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6022 /* make sure they said 0x */
6027 /* Prepare to put the digit we have onto the end
6028 of the number so far. We check for overflows.
6032 n = u << shift; /* make room for the digit */
6033 if (!overflowed && (n >> shift) != u
6034 && !(PL_hints & HINT_NEW_BINARY)) {
6035 warn("Integer overflow in %s number",
6036 (shift == 4) ? "hex"
6037 : ((shift == 3) ? "octal" : "binary"));
6040 u = n | b; /* add the digit to the end */
6045 /* if we get here, we had success: make a scalar value from
6051 if ( PL_hints & HINT_NEW_BINARY)
6052 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6057 handle decimal numbers.
6058 we're also sent here when we read a 0 as the first digit
6060 case '1': case '2': case '3': case '4': case '5':
6061 case '6': case '7': case '8': case '9': case '.':
6064 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6067 /* read next group of digits and _ and copy into d */
6068 while (isDIGIT(*s) || *s == '_') {
6069 /* skip underscores, checking for misplaced ones
6073 dTHR; /* only for ckWARN */
6074 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6075 warner(WARN_SYNTAX, "Misplaced _ in number");
6079 /* check for end of fixed-length buffer */
6081 croak(number_too_long);
6082 /* if we're ok, copy the character */
6087 /* final misplaced underbar check */
6088 if (lastub && s - lastub != 3) {
6090 if (ckWARN(WARN_SYNTAX))
6091 warner(WARN_SYNTAX, "Misplaced _ in number");
6094 /* read a decimal portion if there is one. avoid
6095 3..5 being interpreted as the number 3. followed
6098 if (*s == '.' && s[1] != '.') {
6102 /* copy, ignoring underbars, until we run out of
6103 digits. Note: no misplaced underbar checks!
6105 for (; isDIGIT(*s) || *s == '_'; s++) {
6106 /* fixed length buffer check */
6108 croak(number_too_long);
6114 /* read exponent part, if present */
6115 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6119 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6120 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6122 /* allow positive or negative exponent */
6123 if (*s == '+' || *s == '-')
6126 /* read digits of exponent (no underbars :-) */
6127 while (isDIGIT(*s)) {
6129 croak(number_too_long);
6134 /* terminate the string */
6137 /* make an sv from the string */
6139 /* reset numeric locale in case we were earlier left in Swaziland */
6140 SET_NUMERIC_STANDARD();
6141 value = atof(PL_tokenbuf);
6144 See if we can make do with an integer value without loss of
6145 precision. We use I_V to cast to an int, because some
6146 compilers have issues. Then we try casting it back and see
6147 if it was the same. We only do this if we know we
6148 specifically read an integer.
6150 Note: if floatit is true, then we don't need to do the
6154 if (!floatit && (double)tryiv == value)
6155 sv_setiv(sv, tryiv);
6157 sv_setnv(sv, value);
6158 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6159 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6160 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6164 /* make the op for the constant and return */
6166 yylval.opval = newSVOP(OP_CONST, 0, sv);
6172 scan_formline(register char *s)
6177 SV *stuff = newSVpv("",0);
6178 bool needargs = FALSE;
6181 if (*s == '.' || *s == '}') {
6183 #ifdef PERL_STRICT_CR
6184 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6186 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6188 if (*t == '\n' || t == PL_bufend)
6191 if (PL_in_eval && !PL_rsfp) {
6192 eol = strchr(s,'\n');
6197 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6199 for (t = s; t < eol; t++) {
6200 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6202 goto enough; /* ~~ must be first line in formline */
6204 if (*t == '@' || *t == '^')
6207 sv_catpvn(stuff, s, eol-s);
6211 s = filter_gets(PL_linestr, PL_rsfp, 0);
6212 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6213 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6216 yyerror("Format not terminated");
6226 PL_lex_state = LEX_NORMAL;
6227 PL_nextval[PL_nexttoke].ival = 0;
6231 PL_lex_state = LEX_FORMLINE;
6232 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6234 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6238 SvREFCNT_dec(stuff);
6239 PL_lex_formbrack = 0;
6250 PL_cshlen = strlen(PL_cshname);
6255 start_subparse(I32 is_format, U32 flags)
6258 I32 oldsavestack_ix = PL_savestack_ix;
6259 CV* outsidecv = PL_compcv;
6263 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6265 save_I32(&PL_subline);
6266 save_item(PL_subname);
6268 SAVESPTR(PL_curpad);
6269 SAVESPTR(PL_comppad);
6270 SAVESPTR(PL_comppad_name);
6271 SAVESPTR(PL_compcv);
6272 SAVEI32(PL_comppad_name_fill);
6273 SAVEI32(PL_min_intro_pending);
6274 SAVEI32(PL_max_intro_pending);
6275 SAVEI32(PL_pad_reset_pending);
6277 PL_compcv = (CV*)NEWSV(1104,0);
6278 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6279 CvFLAGS(PL_compcv) |= flags;
6281 PL_comppad = newAV();
6282 av_push(PL_comppad, Nullsv);
6283 PL_curpad = AvARRAY(PL_comppad);
6284 PL_comppad_name = newAV();
6285 PL_comppad_name_fill = 0;
6286 PL_min_intro_pending = 0;
6288 PL_subline = PL_curcop->cop_line;
6290 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6291 PL_curpad[0] = (SV*)newAV();
6292 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6293 #endif /* USE_THREADS */
6295 comppadlist = newAV();
6296 AvREAL_off(comppadlist);
6297 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6298 av_store(comppadlist, 1, (SV*)PL_comppad);
6300 CvPADLIST(PL_compcv) = comppadlist;
6301 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6303 CvOWNER(PL_compcv) = 0;
6304 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6305 MUTEX_INIT(CvMUTEXP(PL_compcv));
6306 #endif /* USE_THREADS */
6308 return oldsavestack_ix;
6327 char *context = NULL;
6331 if (!yychar || (yychar == ';' && !PL_rsfp))
6333 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6334 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6335 while (isSPACE(*PL_oldoldbufptr))
6337 context = PL_oldoldbufptr;
6338 contlen = PL_bufptr - PL_oldoldbufptr;
6340 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6341 PL_oldbufptr != PL_bufptr) {
6342 while (isSPACE(*PL_oldbufptr))
6344 context = PL_oldbufptr;
6345 contlen = PL_bufptr - PL_oldbufptr;
6347 else if (yychar > 255)
6348 where = "next token ???";
6349 else if ((yychar & 127) == 127) {
6350 if (PL_lex_state == LEX_NORMAL ||
6351 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6352 where = "at end of line";
6353 else if (PL_lex_inpat)
6354 where = "within pattern";
6356 where = "within string";
6359 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6361 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6362 else if (isPRINT_LC(yychar))
6363 sv_catpvf(where_sv, "%c", yychar);
6365 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6366 where = SvPVX(where_sv);
6368 msg = sv_2mortal(newSVpv(s, 0));
6369 sv_catpvf(msg, " at %_ line %ld, ",
6370 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6372 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6374 sv_catpvf(msg, "%s\n", where);
6375 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6377 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6378 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6383 else if (PL_in_eval)
6384 sv_catsv(ERRSV, msg);
6386 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6387 if (++PL_error_count >= 10)
6388 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6390 PL_in_my_stash = Nullhv;