3 * Copyright (c) 1991-1997, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It all comes from here, the stench and the peril." --Frodo
17 #define yychar PL_yychar
18 #define yylval PL_yylval
21 static void check_uni _((void));
22 static void force_next _((I32 type));
23 static char *force_version _((char *start));
24 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
25 static SV *tokeq _((SV *sv));
26 static char *scan_const _((char *start));
27 static char *scan_formline _((char *s));
28 static char *scan_heredoc _((char *s));
29 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
31 static char *scan_inputsymbol _((char *start));
32 static char *scan_pat _((char *start, I32 type));
33 static char *scan_str _((char *start));
34 static char *scan_subst _((char *start));
35 static char *scan_trans _((char *start));
36 static char *scan_word _((char *s, char *dest, STRLEN destlen,
37 int allow_package, STRLEN *slp));
38 static char *skipspace _((char *s));
39 static void checkcomma _((char *s, char *name, char *what));
40 static void force_ident _((char *s, int kind));
41 static void incline _((char *s));
42 static int intuit_method _((char *s, GV *gv));
43 static int intuit_more _((char *s));
44 static I32 lop _((I32 f, expectation x, char *s));
45 static void missingterm _((char *s));
46 static void no_op _((char *what, char *s));
47 static void set_csh _((void));
48 static I32 sublex_done _((void));
49 static I32 sublex_push _((void));
50 static I32 sublex_start _((void));
52 static int uni _((I32 f, char *s));
54 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
55 static void restore_rsfp _((void *f));
56 static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
57 static void restore_expect _((void *e));
58 static void restore_lex_expect _((void *e));
59 #endif /* PERL_OBJECT */
61 static char ident_too_long[] = "Identifier too long";
63 #define UTF (PL_hints & HINT_UTF8)
65 * Note: we try to be careful never to call the isXXX_utf8() functions
66 * unless we're pretty sure we've seen the beginning of a UTF-8 character
67 * (that is, the two high bits are set). Otherwise we risk loading in the
68 * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
70 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
72 : isIDFIRST_utf8((U8*)p))
73 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
75 : isALNUM_utf8((U8*)p))
77 /* The following are arranged oddly so that the guard on the switch statement
78 * can get by with a single comparison (if the compiler is smart enough).
81 /* #define LEX_NOTPARSING 11 is done in perl.h. */
84 #define LEX_INTERPNORMAL 9
85 #define LEX_INTERPCASEMOD 8
86 #define LEX_INTERPPUSH 7
87 #define LEX_INTERPSTART 6
88 #define LEX_INTERPEND 5
89 #define LEX_INTERPENDMAYBE 4
90 #define LEX_INTERPCONCAT 3
91 #define LEX_INTERPCONST 2
92 #define LEX_FORMLINE 1
93 #define LEX_KNOWNEXT 0
102 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
104 # include <unistd.h> /* Needed for execv() */
112 #ifdef USE_PURE_BISON
113 YYSTYPE* yylval_pointer = NULL;
114 int* yychar_pointer = NULL;
117 # define yylval (*yylval_pointer)
118 # define yychar (*yychar_pointer)
119 # define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
121 # define PERL_YYLEX_PARAM
124 #include "keywords.h"
129 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
131 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
132 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
133 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
134 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
135 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
136 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
137 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
138 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
139 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
140 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
141 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
142 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
143 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
144 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
145 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
146 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
147 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
148 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
149 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
150 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
152 /* This bit of chicanery makes a unary function followed by
153 * a parenthesis into a function with one argument, highest precedence.
155 #define UNI(f) return(yylval.ival = f, \
158 PL_last_uni = PL_oldbufptr, \
159 PL_last_lop_op = f, \
160 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
162 #define UNIBRACK(f) return(yylval.ival = f, \
164 PL_last_uni = PL_oldbufptr, \
165 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
167 /* grandfather return to old style */
168 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
173 if (*PL_bufptr == '=') {
175 if (toketype == ANDAND)
176 yylval.ival = OP_ANDASSIGN;
177 else if (toketype == OROR)
178 yylval.ival = OP_ORASSIGN;
185 no_op(char *what, char *s)
187 char *oldbp = PL_bufptr;
188 bool is_first = (PL_oldbufptr == PL_linestart);
191 yywarn(form("%s found where operator expected", what));
193 warn("\t(Missing semicolon on previous line?)\n");
194 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
196 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
197 if (t < PL_bufptr && isSPACE(*t))
198 warn("\t(Do you need to predeclare %.*s?)\n",
199 t - PL_oldoldbufptr, PL_oldoldbufptr);
203 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
213 char *nl = strrchr(s,'\n');
219 iscntrl(PL_multi_close)
221 PL_multi_close < 32 || PL_multi_close == 127
225 tmpbuf[1] = toCTRL(PL_multi_close);
231 *tmpbuf = PL_multi_close;
235 q = strchr(s,'"') ? '\'' : '"';
236 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
243 if (ckWARN(WARN_DEPRECATED))
244 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
250 deprecate("comma-less variable list");
256 win32_textfilter(int idx, SV *sv, int maxlen)
258 I32 count = FILTER_READ(idx+1, sv, maxlen);
259 if (count > 0 && !maxlen)
260 win32_strip_return(sv);
268 utf16_textfilter(int idx, SV *sv, int maxlen)
270 I32 count = FILTER_READ(idx+1, sv, maxlen);
274 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
275 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
276 sv_usepvn(sv, (char*)tmps, tend - tmps);
283 utf16rev_textfilter(int idx, SV *sv, int maxlen)
285 I32 count = FILTER_READ(idx+1, sv, maxlen);
289 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
290 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
291 sv_usepvn(sv, (char*)tmps, tend - tmps);
306 SAVEI32(PL_lex_dojoin);
307 SAVEI32(PL_lex_brackets);
308 SAVEI32(PL_lex_fakebrack);
309 SAVEI32(PL_lex_casemods);
310 SAVEI32(PL_lex_starts);
311 SAVEI32(PL_lex_state);
312 SAVESPTR(PL_lex_inpat);
313 SAVEI32(PL_lex_inwhat);
314 SAVEI16(PL_curcop->cop_line);
317 SAVEPPTR(PL_oldbufptr);
318 SAVEPPTR(PL_oldoldbufptr);
319 SAVEPPTR(PL_linestart);
320 SAVESPTR(PL_linestr);
321 SAVEPPTR(PL_lex_brackstack);
322 SAVEPPTR(PL_lex_casestack);
323 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
324 SAVESPTR(PL_lex_stuff);
325 SAVEI32(PL_lex_defer);
326 SAVESPTR(PL_lex_repl);
327 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
328 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
330 PL_lex_state = LEX_NORMAL;
334 PL_lex_fakebrack = 0;
335 New(899, PL_lex_brackstack, 120, char);
336 New(899, PL_lex_casestack, 12, char);
337 SAVEFREEPV(PL_lex_brackstack);
338 SAVEFREEPV(PL_lex_casestack);
340 *PL_lex_casestack = '\0';
343 PL_lex_stuff = Nullsv;
344 PL_lex_repl = Nullsv;
348 if (SvREADONLY(PL_linestr))
349 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
350 s = SvPV(PL_linestr, len);
351 if (len && s[len-1] != ';') {
352 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
353 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
354 sv_catpvn(PL_linestr, "\n;", 2);
356 SvTEMP_off(PL_linestr);
357 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
358 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
360 PL_rs = newSVpv("\n", 1);
367 PL_doextract = FALSE;
371 restore_rsfp(void *f)
373 PerlIO *fp = (PerlIO*)f;
375 if (PL_rsfp == PerlIO_stdin())
376 PerlIO_clearerr(PL_rsfp);
377 else if (PL_rsfp && (PL_rsfp != fp))
378 PerlIO_close(PL_rsfp);
383 restore_expect(void *e)
385 /* a safe way to store a small integer in a pointer */
386 PL_expect = (expectation)((char *)e - PL_tokenbuf);
390 restore_lex_expect(void *e)
392 /* a safe way to store a small integer in a pointer */
393 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
405 PL_curcop->cop_line++;
408 while (*s == ' ' || *s == '\t') s++;
409 if (strnEQ(s, "line ", 5)) {
418 while (*s == ' ' || *s == '\t')
420 if (*s == '"' && (t = strchr(s+1, '"')))
424 return; /* false alarm */
425 for (t = s; !isSPACE(*t); t++) ;
430 PL_curcop->cop_filegv = gv_fetchfile(s);
432 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
434 PL_curcop->cop_line = atoi(n)-1;
438 skipspace(register char *s)
441 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
442 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
448 while (s < PL_bufend && isSPACE(*s)) {
449 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
452 if (s < PL_bufend && *s == '#') {
453 while (s < PL_bufend && *s != '\n')
457 if (PL_in_eval && !PL_rsfp) {
463 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
465 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
466 if (PL_minus_n || PL_minus_p) {
467 sv_setpv(PL_linestr,PL_minus_p ?
468 ";}continue{print or die qq(-p destination: $!\\n)" :
470 sv_catpv(PL_linestr,";}");
471 PL_minus_n = PL_minus_p = 0;
474 sv_setpv(PL_linestr,";");
475 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
476 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
477 if (PL_preprocess && !PL_in_eval)
478 (void)PerlProc_pclose(PL_rsfp);
479 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
480 PerlIO_clearerr(PL_rsfp);
482 (void)PerlIO_close(PL_rsfp);
486 PL_linestart = PL_bufptr = s + prevlen;
487 PL_bufend = s + SvCUR(PL_linestr);
490 if (PERLDB_LINE && PL_curstash != PL_debstash) {
491 SV *sv = NEWSV(85,0);
493 sv_upgrade(sv, SVt_PVMG);
494 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
495 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
506 if (PL_oldoldbufptr != PL_last_uni)
508 while (isSPACE(*PL_last_uni))
510 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
511 if ((t = strchr(s, '(')) && t < PL_bufptr)
515 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
522 #define UNI(f) return uni(f,s)
530 PL_last_uni = PL_oldbufptr;
541 #endif /* CRIPPLED_CC */
543 #define LOP(f,x) return lop(f,x,s)
546 lop(I32 f, expectation x, char *s)
553 PL_last_lop = PL_oldbufptr;
569 PL_nexttype[PL_nexttoke] = type;
571 if (PL_lex_state != LEX_KNOWNEXT) {
572 PL_lex_defer = PL_lex_state;
573 PL_lex_expect = PL_expect;
574 PL_lex_state = LEX_KNOWNEXT;
579 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
584 start = skipspace(start);
586 if (isIDFIRST_lazy(s) ||
587 (allow_pack && *s == ':') ||
588 (allow_initial_tick && *s == '\'') )
590 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
591 if (check_keyword && keyword(PL_tokenbuf, len))
593 if (token == METHOD) {
598 PL_expect = XOPERATOR;
603 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
604 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
611 force_ident(register char *s, int kind)
614 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
615 PL_nextval[PL_nexttoke].opval = o;
618 dTHR; /* just for in_eval */
619 o->op_private = OPpCONST_ENTERED;
620 /* XXX see note in pp_entereval() for why we forgo typo
621 warnings if the symbol must be introduced in an eval.
623 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
624 kind == '$' ? SVt_PV :
625 kind == '@' ? SVt_PVAV :
626 kind == '%' ? SVt_PVHV :
634 force_version(char *s)
636 OP *version = Nullop;
640 /* default VERSION number -- GBARR */
645 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
646 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
648 /* real VERSION number -- GBARR */
649 version = yylval.opval;
653 /* NOTE: The parser sees the package name and the VERSION swapped */
654 PL_nextval[PL_nexttoke].opval = version;
672 s = SvPV_force(sv, len);
676 while (s < send && *s != '\\')
681 if ( PL_hints & HINT_NEW_STRING )
682 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
685 if (s + 1 < send && (s[1] == '\\'))
686 s++; /* all that, just for this */
691 SvCUR_set(sv, d - SvPVX(sv));
693 if ( PL_hints & HINT_NEW_STRING )
694 return new_constant(NULL, 0, "q", sv, pv, "q");
701 register I32 op_type = yylval.ival;
703 if (op_type == OP_NULL) {
704 yylval.opval = PL_lex_op;
708 if (op_type == OP_CONST || op_type == OP_READLINE) {
709 SV *sv = tokeq(PL_lex_stuff);
711 if (SvTYPE(sv) == SVt_PVIV) {
712 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
718 nsv = newSVpv(p, len);
722 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
723 PL_lex_stuff = Nullsv;
727 PL_sublex_info.super_state = PL_lex_state;
728 PL_sublex_info.sub_inwhat = op_type;
729 PL_sublex_info.sub_op = PL_lex_op;
730 PL_lex_state = LEX_INTERPPUSH;
734 yylval.opval = PL_lex_op;
748 PL_lex_state = PL_sublex_info.super_state;
749 SAVEI32(PL_lex_dojoin);
750 SAVEI32(PL_lex_brackets);
751 SAVEI32(PL_lex_fakebrack);
752 SAVEI32(PL_lex_casemods);
753 SAVEI32(PL_lex_starts);
754 SAVEI32(PL_lex_state);
755 SAVESPTR(PL_lex_inpat);
756 SAVEI32(PL_lex_inwhat);
757 SAVEI16(PL_curcop->cop_line);
759 SAVEPPTR(PL_oldbufptr);
760 SAVEPPTR(PL_oldoldbufptr);
761 SAVEPPTR(PL_linestart);
762 SAVESPTR(PL_linestr);
763 SAVEPPTR(PL_lex_brackstack);
764 SAVEPPTR(PL_lex_casestack);
766 PL_linestr = PL_lex_stuff;
767 PL_lex_stuff = Nullsv;
769 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
770 PL_bufend += SvCUR(PL_linestr);
771 SAVEFREESV(PL_linestr);
773 PL_lex_dojoin = FALSE;
775 PL_lex_fakebrack = 0;
776 New(899, PL_lex_brackstack, 120, char);
777 New(899, PL_lex_casestack, 12, char);
778 SAVEFREEPV(PL_lex_brackstack);
779 SAVEFREEPV(PL_lex_casestack);
781 *PL_lex_casestack = '\0';
783 PL_lex_state = LEX_INTERPCONCAT;
784 PL_curcop->cop_line = PL_multi_start;
786 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
787 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
788 PL_lex_inpat = PL_sublex_info.sub_op;
790 PL_lex_inpat = Nullop;
798 if (!PL_lex_starts++) {
799 PL_expect = XOPERATOR;
800 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
804 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
805 PL_lex_state = LEX_INTERPCASEMOD;
806 return yylex(PERL_YYLEX_PARAM);
809 /* Is there a right-hand side to take care of? */
810 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
811 PL_linestr = PL_lex_repl;
813 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
814 PL_bufend += SvCUR(PL_linestr);
815 SAVEFREESV(PL_linestr);
816 PL_lex_dojoin = FALSE;
818 PL_lex_fakebrack = 0;
820 *PL_lex_casestack = '\0';
822 if (SvCOMPILED(PL_lex_repl)) {
823 PL_lex_state = LEX_INTERPNORMAL;
825 /* we don't clear PL_lex_repl here, so that we can check later
826 whether this is an evalled subst; that means we rely on the
827 logic to ensure sublex_done() is called again only via the
828 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
831 PL_lex_state = LEX_INTERPCONCAT;
832 PL_lex_repl = Nullsv;
838 PL_bufend = SvPVX(PL_linestr);
839 PL_bufend += SvCUR(PL_linestr);
840 PL_expect = XOPERATOR;
848 Extracts a pattern, double-quoted string, or transliteration. This
851 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
852 processing a pattern (PL_lex_inpat is true), a transliteration
853 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
855 Returns a pointer to the character scanned up to. Iff this is
856 advanced from the start pointer supplied (ie if anything was
857 successfully parsed), will leave an OP for the substring scanned
858 in yylval. Caller must intuit reason for not parsing further
859 by looking at the next characters herself.
863 double-quoted style: \r and \n
864 regexp special ones: \D \s
866 backrefs: \1 (deprecated in substitution replacements)
867 case and quoting: \U \Q \E
868 stops on @ and $, but not for $ as tail anchor
871 characters are VERY literal, except for - not at the start or end
872 of the string, which indicates a range. scan_const expands the
873 range to the full set of intermediate characters.
875 In double-quoted strings:
877 double-quoted style: \r and \n
879 backrefs: \1 (deprecated)
880 case and quoting: \U \Q \E
883 scan_const does *not* construct ops to handle interpolated strings.
884 It stops processing as soon as it finds an embedded $ or @ variable
885 and leaves it to the caller to work out what's going on.
887 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
889 $ in pattern could be $foo or could be tail anchor. Assumption:
890 it's a tail anchor if $ is the last thing in the string, or if it's
891 followed by one of ")| \n\t"
893 \1 (backreferences) are turned into $1
895 The structure of the code is
896 while (there's a character to process) {
897 handle transliteration ranges
899 skip # initiated comments in //x patterns
900 check for embedded @foo
901 check for embedded scalars
903 leave intact backslashes from leave (below)
904 deprecate \1 in strings and sub replacements
905 handle string-changing backslashes \l \U \Q \E, etc.
906 switch (what was escaped) {
907 handle - in a transliteration (becomes a literal -)
908 handle \132 octal characters
909 handle 0x15 hex characters
910 handle \cV (control V)
911 handle printf backslashes (\f, \r, \n, etc)
914 } (end while character to read)
919 scan_const(char *start)
921 register char *send = PL_bufend; /* end of the constant */
922 SV *sv = NEWSV(93, send - start); /* sv for the constant */
923 register char *s = start; /* start of the constant */
924 register char *d = SvPVX(sv); /* destination for copies */
925 bool dorange = FALSE; /* are we in a translit range? */
927 I32 utf = PL_lex_inwhat == OP_TRANS
928 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
930 I32 thisutf = PL_lex_inwhat == OP_TRANS
931 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
934 /* leaveit is the set of acceptably-backslashed characters */
937 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
940 while (s < send || dorange) {
941 /* get transliterations out of the way (they're most literal) */
942 if (PL_lex_inwhat == OP_TRANS) {
943 /* expand a range A-Z to the full set of characters. AIE! */
945 I32 i; /* current expanded character */
946 I32 min; /* first character in range */
947 I32 max; /* last character in range */
949 i = d - SvPVX(sv); /* remember current offset */
950 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
951 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
952 d -= 2; /* eat the first char and the - */
954 min = (U8)*d; /* first char in range */
955 max = (U8)d[1]; /* last char in range */
958 if ((isLOWER(min) && isLOWER(max)) ||
959 (isUPPER(min) && isUPPER(max))) {
961 for (i = min; i <= max; i++)
965 for (i = min; i <= max; i++)
972 for (i = min; i <= max; i++)
975 /* mark the range as done, and continue */
980 /* range begins (ignore - as first or last char) */
981 else if (*s == '-' && s+1 < send && s != start) {
983 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
992 /* if we get here, we're not doing a transliteration */
994 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
995 except for the last char, which will be done separately. */
996 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
998 while (s < send && *s != ')')
1000 } else if (s[2] == '{'
1001 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1003 char *regparse = s + (s[2] == '{' ? 3 : 4);
1006 while (count && (c = *regparse)) {
1007 if (c == '\\' && regparse[1])
1015 if (*regparse != ')') {
1016 regparse--; /* Leave one char for continuation. */
1017 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1019 while (s < regparse)
1024 /* likewise skip #-initiated comments in //x patterns */
1025 else if (*s == '#' && PL_lex_inpat &&
1026 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1027 while (s+1 < send && *s != '\n')
1031 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1032 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1035 /* check for embedded scalars. only stop if we're sure it's a
1038 else if (*s == '$') {
1039 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1041 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1042 break; /* in regexp, $ might be tail anchor */
1045 /* (now in tr/// code again) */
1047 if (*s & 0x80 && thisutf) {
1048 dTHR; /* only for ckWARN */
1049 if (ckWARN(WARN_UTF8)) {
1050 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1060 if (*s == '\\' && s+1 < send) {
1063 /* some backslashes we leave behind */
1064 if (*leaveit && *s && strchr(leaveit, *s)) {
1070 /* deprecate \1 in strings and substitution replacements */
1071 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1072 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1074 dTHR; /* only for ckWARN */
1075 if (ckWARN(WARN_SYNTAX))
1076 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1081 /* string-change backslash escapes */
1082 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1087 /* if we get here, it's either a quoted -, or a digit */
1090 /* quoted - in transliterations */
1092 if (PL_lex_inwhat == OP_TRANS) {
1100 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1102 "Unrecognized escape \\%c passed through",
1104 /* default action is to copy the quoted character */
1109 /* \132 indicates an octal constant */
1110 case '0': case '1': case '2': case '3':
1111 case '4': case '5': case '6': case '7':
1112 *d++ = scan_oct(s, 3, &len);
1116 /* \x24 indicates a hex constant */
1120 char* e = strchr(s, '}');
1123 yyerror("Missing right brace on \\x{}");
1128 if (ckWARN(WARN_UTF8))
1130 "Use of \\x{} without utf8 declaration");
1132 /* note: utf always shorter than hex */
1133 d = (char*)uv_to_utf8((U8*)d,
1134 scan_hex(s + 1, e - s - 1, &len));
1139 UV uv = (UV)scan_hex(s, 2, &len);
1140 if (utf && PL_lex_inwhat == OP_TRANS &&
1141 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1143 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1146 if (uv >= 127 && UTF) {
1148 if (ckWARN(WARN_UTF8))
1150 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1159 /* \c is a control character */
1173 /* printf-style backslashes, formfeeds, newlines, etc */
1199 } /* end if (backslash) */
1202 } /* while loop to process each character */
1204 /* terminate the string and set up the sv */
1206 SvCUR_set(sv, d - SvPVX(sv));
1209 /* shrink the sv if we allocated more than we used */
1210 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1211 SvLEN_set(sv, SvCUR(sv) + 1);
1212 Renew(SvPVX(sv), SvLEN(sv), char);
1215 /* return the substring (via yylval) only if we parsed anything */
1216 if (s > PL_bufptr) {
1217 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1218 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1220 ( PL_lex_inwhat == OP_TRANS
1222 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1225 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1231 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1233 intuit_more(register char *s)
1235 if (PL_lex_brackets)
1237 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1239 if (*s != '{' && *s != '[')
1244 /* In a pattern, so maybe we have {n,m}. */
1261 /* On the other hand, maybe we have a character class */
1264 if (*s == ']' || *s == '^')
1267 int weight = 2; /* let's weigh the evidence */
1269 unsigned char un_char = 255, last_un_char;
1270 char *send = strchr(s,']');
1271 char tmpbuf[sizeof PL_tokenbuf * 4];
1273 if (!send) /* has to be an expression */
1276 Zero(seen,256,char);
1279 else if (isDIGIT(*s)) {
1281 if (isDIGIT(s[1]) && s[2] == ']')
1287 for (; s < send; s++) {
1288 last_un_char = un_char;
1289 un_char = (unsigned char)*s;
1294 weight -= seen[un_char] * 10;
1295 if (isALNUM_lazy(s+1)) {
1296 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1297 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1302 else if (*s == '$' && s[1] &&
1303 strchr("[#!%*<>()-=",s[1])) {
1304 if (/*{*/ strchr("])} =",s[2]))
1313 if (strchr("wds]",s[1]))
1315 else if (seen['\''] || seen['"'])
1317 else if (strchr("rnftbxcav",s[1]))
1319 else if (isDIGIT(s[1])) {
1321 while (s[1] && isDIGIT(s[1]))
1331 if (strchr("aA01! ",last_un_char))
1333 if (strchr("zZ79~",s[1]))
1335 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1336 weight -= 5; /* cope with negative subscript */
1339 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1340 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1345 if (keyword(tmpbuf, d - tmpbuf))
1348 if (un_char == last_un_char + 1)
1350 weight -= seen[un_char];
1355 if (weight >= 0) /* probably a character class */
1363 intuit_method(char *start, GV *gv)
1365 char *s = start + (*start == '$');
1366 char tmpbuf[sizeof PL_tokenbuf];
1374 if ((cv = GvCVu(gv))) {
1375 char *proto = SvPVX(cv);
1385 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1386 if (*start == '$') {
1387 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1392 return *s == '(' ? FUNCMETH : METHOD;
1394 if (!keyword(tmpbuf, len)) {
1395 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1400 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1401 if (indirgv && GvCVu(indirgv))
1403 /* filehandle or package name makes it a method */
1404 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1406 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1407 return 0; /* no assumptions -- "=>" quotes bearword */
1409 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1411 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1415 return *s == '(' ? FUNCMETH : METHOD;
1425 char *pdb = PerlEnv_getenv("PERL5DB");
1429 SETERRNO(0,SS$_NORMAL);
1430 return "BEGIN { require 'perl5db.pl' }";
1436 /* Encoded script support. filter_add() effectively inserts a
1437 * 'pre-processing' function into the current source input stream.
1438 * Note that the filter function only applies to the current source file
1439 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1441 * The datasv parameter (which may be NULL) can be used to pass
1442 * private data to this instance of the filter. The filter function
1443 * can recover the SV using the FILTER_DATA macro and use it to
1444 * store private buffers and state information.
1446 * The supplied datasv parameter is upgraded to a PVIO type
1447 * and the IoDIRP field is used to store the function pointer.
1448 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1449 * private use must be set using malloc'd pointers.
1451 static int filter_debug = 0;
1454 filter_add(filter_t funcp, SV *datasv)
1456 if (!funcp){ /* temporary handy debugging hack to be deleted */
1457 filter_debug = atoi((char*)datasv);
1460 if (!PL_rsfp_filters)
1461 PL_rsfp_filters = newAV();
1463 datasv = NEWSV(255,0);
1464 if (!SvUPGRADE(datasv, SVt_PVIO))
1465 die("Can't upgrade filter_add data to SVt_PVIO");
1466 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1469 warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1471 av_unshift(PL_rsfp_filters, 1);
1472 av_store(PL_rsfp_filters, 0, datasv) ;
1477 /* Delete most recently added instance of this filter function. */
1479 filter_del(filter_t funcp)
1482 warn("filter_del func %p", funcp);
1483 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1485 /* if filter is on top of stack (usual case) just pop it off */
1486 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1487 sv_free(av_pop(PL_rsfp_filters));
1491 /* we need to search for the correct entry and clear it */
1492 die("filter_del can only delete in reverse order (currently)");
1496 /* Invoke the n'th filter function for the current rsfp. */
1498 filter_read(int idx, SV *buf_sv, int maxlen)
1501 /* 0 = read one text line */
1506 if (!PL_rsfp_filters)
1508 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1509 /* Provide a default input filter to make life easy. */
1510 /* Note that we append to the line. This is handy. */
1512 warn("filter_read %d: from rsfp\n", idx);
1516 int old_len = SvCUR(buf_sv) ;
1518 /* ensure buf_sv is large enough */
1519 SvGROW(buf_sv, old_len + maxlen) ;
1520 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1521 if (PerlIO_error(PL_rsfp))
1522 return -1; /* error */
1524 return 0 ; /* end of file */
1526 SvCUR_set(buf_sv, old_len + len) ;
1529 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1530 if (PerlIO_error(PL_rsfp))
1531 return -1; /* error */
1533 return 0 ; /* end of file */
1536 return SvCUR(buf_sv);
1538 /* Skip this filter slot if filter has been deleted */
1539 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1541 warn("filter_read %d: skipped (filter deleted)\n", idx);
1542 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1544 /* Get function pointer hidden within datasv */
1545 funcp = (filter_t)IoDIRP(datasv);
1548 warn("filter_read %d: via function %p (%s)\n",
1549 idx, funcp, SvPV(datasv,n_a));
1551 /* Call function. The function is expected to */
1552 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1553 /* Return: <0:error, =0:eof, >0:not eof */
1554 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1558 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1561 if (!PL_rsfp_filters) {
1562 filter_add(win32_textfilter,NULL);
1565 if (PL_rsfp_filters) {
1568 SvCUR_set(sv, 0); /* start with empty line */
1569 if (FILTER_READ(0, sv, 0) > 0)
1570 return ( SvPVX(sv) ) ;
1575 return (sv_gets(sv, fp, append));
1580 static char* exp_name[] =
1581 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1587 Works out what to call the token just pulled out of the input
1588 stream. The yacc parser takes care of taking the ops we return and
1589 stitching them into a tree.
1595 if read an identifier
1596 if we're in a my declaration
1597 croak if they tried to say my($foo::bar)
1598 build the ops for a my() declaration
1599 if it's an access to a my() variable
1600 are we in a sort block?
1601 croak if my($a); $a <=> $b
1602 build ops for access to a my() variable
1603 if in a dq string, and they've said @foo and we can't find @foo
1605 build ops for a bareword
1606 if we already built the token before, use it.
1609 int yylex(PERL_YYLEX_PARAM_DECL)
1619 #ifdef USE_PURE_BISON
1620 yylval_pointer = lvalp;
1621 yychar_pointer = lcharp;
1624 /* check if there's an identifier for us to look at */
1625 if (PL_pending_ident) {
1626 /* pit holds the identifier we read and pending_ident is reset */
1627 char pit = PL_pending_ident;
1628 PL_pending_ident = 0;
1630 /* if we're in a my(), we can't allow dynamics here.
1631 $foo'bar has already been turned into $foo::bar, so
1632 just check for colons.
1634 if it's a legal name, the OP is a PADANY.
1637 if (strchr(PL_tokenbuf,':'))
1638 croak(PL_no_myglob,PL_tokenbuf);
1640 yylval.opval = newOP(OP_PADANY, 0);
1641 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1646 build the ops for accesses to a my() variable.
1648 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1649 then used in a comparison. This catches most, but not
1650 all cases. For instance, it catches
1651 sort { my($a); $a <=> $b }
1653 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1654 (although why you'd do that is anyone's guess).
1657 if (!strchr(PL_tokenbuf,':')) {
1659 /* Check for single character per-thread SVs */
1660 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1661 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1662 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1664 yylval.opval = newOP(OP_THREADSV, 0);
1665 yylval.opval->op_targ = tmp;
1668 #endif /* USE_THREADS */
1669 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1670 /* if it's a sort block and they're naming $a or $b */
1671 if (PL_last_lop_op == OP_SORT &&
1672 PL_tokenbuf[0] == '$' &&
1673 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1676 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1677 d < PL_bufend && *d != '\n';
1680 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1681 croak("Can't use \"my %s\" in sort comparison",
1687 yylval.opval = newOP(OP_PADANY, 0);
1688 yylval.opval->op_targ = tmp;
1694 Whine if they've said @foo in a doublequoted string,
1695 and @foo isn't a variable we can find in the symbol
1698 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1699 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1700 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1701 yyerror(form("In string, %s now must be written as \\%s",
1702 PL_tokenbuf, PL_tokenbuf));
1705 /* build ops for a bareword */
1706 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1707 yylval.opval->op_private = OPpCONST_ENTERED;
1708 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1709 ((PL_tokenbuf[0] == '$') ? SVt_PV
1710 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1715 /* no identifier pending identification */
1717 switch (PL_lex_state) {
1719 case LEX_NORMAL: /* Some compilers will produce faster */
1720 case LEX_INTERPNORMAL: /* code if we comment these out. */
1724 /* when we're already built the next token, just pull it out the queue */
1727 yylval = PL_nextval[PL_nexttoke];
1729 PL_lex_state = PL_lex_defer;
1730 PL_expect = PL_lex_expect;
1731 PL_lex_defer = LEX_NORMAL;
1733 return(PL_nexttype[PL_nexttoke]);
1735 /* interpolated case modifiers like \L \U, including \Q and \E.
1736 when we get here, PL_bufptr is at the \
1738 case LEX_INTERPCASEMOD:
1740 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1741 croak("panic: INTERPCASEMOD");
1743 /* handle \E or end of string */
1744 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1748 if (PL_lex_casemods) {
1749 oldmod = PL_lex_casestack[--PL_lex_casemods];
1750 PL_lex_casestack[PL_lex_casemods] = '\0';
1752 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1754 PL_lex_state = LEX_INTERPCONCAT;
1758 if (PL_bufptr != PL_bufend)
1760 PL_lex_state = LEX_INTERPCONCAT;
1761 return yylex(PERL_YYLEX_PARAM);
1765 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1766 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1767 if (strchr("LU", *s) &&
1768 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1770 PL_lex_casestack[--PL_lex_casemods] = '\0';
1773 if (PL_lex_casemods > 10) {
1774 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1775 if (newlb != PL_lex_casestack) {
1777 PL_lex_casestack = newlb;
1780 PL_lex_casestack[PL_lex_casemods++] = *s;
1781 PL_lex_casestack[PL_lex_casemods] = '\0';
1782 PL_lex_state = LEX_INTERPCONCAT;
1783 PL_nextval[PL_nexttoke].ival = 0;
1786 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1788 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1790 PL_nextval[PL_nexttoke].ival = OP_LC;
1792 PL_nextval[PL_nexttoke].ival = OP_UC;
1794 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1796 croak("panic: yylex");
1799 if (PL_lex_starts) {
1805 return yylex(PERL_YYLEX_PARAM);
1808 case LEX_INTERPPUSH:
1809 return sublex_push();
1811 case LEX_INTERPSTART:
1812 if (PL_bufptr == PL_bufend)
1813 return sublex_done();
1815 PL_lex_dojoin = (*PL_bufptr == '@');
1816 PL_lex_state = LEX_INTERPNORMAL;
1817 if (PL_lex_dojoin) {
1818 PL_nextval[PL_nexttoke].ival = 0;
1821 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1822 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1823 force_next(PRIVATEREF);
1825 force_ident("\"", '$');
1826 #endif /* USE_THREADS */
1827 PL_nextval[PL_nexttoke].ival = 0;
1829 PL_nextval[PL_nexttoke].ival = 0;
1831 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1834 if (PL_lex_starts++) {
1838 return yylex(PERL_YYLEX_PARAM);
1840 case LEX_INTERPENDMAYBE:
1841 if (intuit_more(PL_bufptr)) {
1842 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1848 if (PL_lex_dojoin) {
1849 PL_lex_dojoin = FALSE;
1850 PL_lex_state = LEX_INTERPCONCAT;
1853 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl && SvCOMPILED(PL_lex_repl)) {
1854 if (PL_bufptr != PL_bufend)
1855 croak("Bad evalled substitution pattern");
1856 PL_lex_repl = Nullsv;
1859 case LEX_INTERPCONCAT:
1861 if (PL_lex_brackets)
1862 croak("panic: INTERPCONCAT");
1864 if (PL_bufptr == PL_bufend)
1865 return sublex_done();
1867 if (SvIVX(PL_linestr) == '\'') {
1868 SV *sv = newSVsv(PL_linestr);
1871 else if ( PL_hints & HINT_NEW_RE )
1872 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1873 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1877 s = scan_const(PL_bufptr);
1879 PL_lex_state = LEX_INTERPCASEMOD;
1881 PL_lex_state = LEX_INTERPSTART;
1884 if (s != PL_bufptr) {
1885 PL_nextval[PL_nexttoke] = yylval;
1888 if (PL_lex_starts++)
1892 return yylex(PERL_YYLEX_PARAM);
1896 return yylex(PERL_YYLEX_PARAM);
1898 PL_lex_state = LEX_NORMAL;
1899 s = scan_formline(PL_bufptr);
1900 if (!PL_lex_formbrack)
1906 PL_oldoldbufptr = PL_oldbufptr;
1909 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1915 if (isIDFIRST_lazy(s))
1917 croak("Unrecognized character \\x%02X", *s & 255);
1920 goto fake_eof; /* emulate EOF on ^D or ^Z */
1925 if (PL_lex_brackets)
1926 yyerror("Missing right bracket");
1929 if (s++ < PL_bufend)
1930 goto retry; /* ignore stray nulls */
1933 if (!PL_in_eval && !PL_preambled) {
1934 PL_preambled = TRUE;
1935 sv_setpv(PL_linestr,incl_perldb());
1936 if (SvCUR(PL_linestr))
1937 sv_catpv(PL_linestr,";");
1939 while(AvFILLp(PL_preambleav) >= 0) {
1940 SV *tmpsv = av_shift(PL_preambleav);
1941 sv_catsv(PL_linestr, tmpsv);
1942 sv_catpv(PL_linestr, ";");
1945 sv_free((SV*)PL_preambleav);
1946 PL_preambleav = NULL;
1948 if (PL_minus_n || PL_minus_p) {
1949 sv_catpv(PL_linestr, "LINE: while (<>) {");
1951 sv_catpv(PL_linestr,"chomp;");
1953 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1955 GvIMPORTED_AV_on(gv);
1957 if (strchr("/'\"", *PL_splitstr)
1958 && strchr(PL_splitstr + 1, *PL_splitstr))
1959 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1962 s = "'~#\200\1'"; /* surely one char is unused...*/
1963 while (s[1] && strchr(PL_splitstr, *s)) s++;
1965 sv_catpvf(PL_linestr, "@F=split(%s%c",
1966 "q" + (delim == '\''), delim);
1967 for (s = PL_splitstr; *s; s++) {
1969 sv_catpvn(PL_linestr, "\\", 1);
1970 sv_catpvn(PL_linestr, s, 1);
1972 sv_catpvf(PL_linestr, "%c);", delim);
1976 sv_catpv(PL_linestr,"@F=split(' ');");
1979 sv_catpv(PL_linestr, "\n");
1980 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1981 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1982 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1983 SV *sv = NEWSV(85,0);
1985 sv_upgrade(sv, SVt_PVMG);
1986 sv_setsv(sv,PL_linestr);
1987 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1992 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1995 if (PL_preprocess && !PL_in_eval)
1996 (void)PerlProc_pclose(PL_rsfp);
1997 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1998 PerlIO_clearerr(PL_rsfp);
2000 (void)PerlIO_close(PL_rsfp);
2002 PL_doextract = FALSE;
2004 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2005 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2006 sv_catpv(PL_linestr,";}");
2007 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2008 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2009 PL_minus_n = PL_minus_p = 0;
2012 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2013 sv_setpv(PL_linestr,"");
2014 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2017 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2018 PL_doextract = FALSE;
2020 /* Incest with pod. */
2021 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2022 sv_setpv(PL_linestr, "");
2023 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2024 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2025 PL_doextract = FALSE;
2029 } while (PL_doextract);
2030 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2031 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2032 SV *sv = NEWSV(85,0);
2034 sv_upgrade(sv, SVt_PVMG);
2035 sv_setsv(sv,PL_linestr);
2036 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2038 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2039 if (PL_curcop->cop_line == 1) {
2040 while (s < PL_bufend && isSPACE(*s))
2042 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2046 if (*s == '#' && *(s+1) == '!')
2048 #ifdef ALTERNATE_SHEBANG
2050 static char as[] = ALTERNATE_SHEBANG;
2051 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2052 d = s + (sizeof(as) - 1);
2054 #endif /* ALTERNATE_SHEBANG */
2063 while (*d && !isSPACE(*d))
2067 #ifdef ARG_ZERO_IS_SCRIPT
2068 if (ipathend > ipath) {
2070 * HP-UX (at least) sets argv[0] to the script name,
2071 * which makes $^X incorrect. And Digital UNIX and Linux,
2072 * at least, set argv[0] to the basename of the Perl
2073 * interpreter. So, having found "#!", we'll set it right.
2075 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2076 assert(SvPOK(x) || SvGMAGICAL(x));
2077 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2078 sv_setpvn(x, ipath, ipathend - ipath);
2081 TAINT_NOT; /* $^X is always tainted, but that's OK */
2083 #endif /* ARG_ZERO_IS_SCRIPT */
2088 d = instr(s,"perl -");
2090 d = instr(s,"perl");
2091 #ifdef ALTERNATE_SHEBANG
2093 * If the ALTERNATE_SHEBANG on this system starts with a
2094 * character that can be part of a Perl expression, then if
2095 * we see it but not "perl", we're probably looking at the
2096 * start of Perl code, not a request to hand off to some
2097 * other interpreter. Similarly, if "perl" is there, but
2098 * not in the first 'word' of the line, we assume the line
2099 * contains the start of the Perl program.
2101 if (d && *s != '#') {
2103 while (*c && !strchr("; \t\r\n\f\v#", *c))
2106 d = Nullch; /* "perl" not in first word; ignore */
2108 *s = '#'; /* Don't try to parse shebang line */
2110 #endif /* ALTERNATE_SHEBANG */
2115 !instr(s,"indir") &&
2116 instr(PL_origargv[0],"perl"))
2122 while (s < PL_bufend && isSPACE(*s))
2124 if (s < PL_bufend) {
2125 Newz(899,newargv,PL_origargc+3,char*);
2127 while (s < PL_bufend && !isSPACE(*s))
2130 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2133 newargv = PL_origargv;
2135 execv(ipath, newargv);
2136 croak("Can't exec %s", ipath);
2139 U32 oldpdb = PL_perldb;
2140 bool oldn = PL_minus_n;
2141 bool oldp = PL_minus_p;
2143 while (*d && !isSPACE(*d)) d++;
2144 while (*d == ' ' || *d == '\t') d++;
2148 if (*d == 'M' || *d == 'm') {
2150 while (*d && !isSPACE(*d)) d++;
2151 croak("Too late for \"-%.*s\" option",
2154 d = moreswitches(d);
2156 if (PERLDB_LINE && !oldpdb ||
2157 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2158 /* if we have already added "LINE: while (<>) {",
2159 we must not do it again */
2161 sv_setpv(PL_linestr, "");
2162 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2163 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2164 PL_preambled = FALSE;
2166 (void)gv_fetchfile(PL_origfilename);
2173 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2175 PL_lex_state = LEX_FORMLINE;
2176 return yylex(PERL_YYLEX_PARAM);
2180 #ifdef PERL_STRICT_CR
2181 warn("Illegal character \\%03o (carriage return)", '\r');
2183 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2185 case ' ': case '\t': case '\f': case 013:
2190 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2192 while (s < d && *s != '\n')
2197 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2199 PL_lex_state = LEX_FORMLINE;
2200 return yylex(PERL_YYLEX_PARAM);
2209 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2214 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2217 if (strnEQ(s,"=>",2)) {
2218 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2219 OPERATOR('-'); /* unary minus */
2221 PL_last_uni = PL_oldbufptr;
2222 PL_last_lop_op = OP_FTEREAD; /* good enough */
2224 case 'r': FTST(OP_FTEREAD);
2225 case 'w': FTST(OP_FTEWRITE);
2226 case 'x': FTST(OP_FTEEXEC);
2227 case 'o': FTST(OP_FTEOWNED);
2228 case 'R': FTST(OP_FTRREAD);
2229 case 'W': FTST(OP_FTRWRITE);
2230 case 'X': FTST(OP_FTREXEC);
2231 case 'O': FTST(OP_FTROWNED);
2232 case 'e': FTST(OP_FTIS);
2233 case 'z': FTST(OP_FTZERO);
2234 case 's': FTST(OP_FTSIZE);
2235 case 'f': FTST(OP_FTFILE);
2236 case 'd': FTST(OP_FTDIR);
2237 case 'l': FTST(OP_FTLINK);
2238 case 'p': FTST(OP_FTPIPE);
2239 case 'S': FTST(OP_FTSOCK);
2240 case 'u': FTST(OP_FTSUID);
2241 case 'g': FTST(OP_FTSGID);
2242 case 'k': FTST(OP_FTSVTX);
2243 case 'b': FTST(OP_FTBLK);
2244 case 'c': FTST(OP_FTCHR);
2245 case 't': FTST(OP_FTTTY);
2246 case 'T': FTST(OP_FTTEXT);
2247 case 'B': FTST(OP_FTBINARY);
2248 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2249 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2250 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2252 croak("Unrecognized file test: -%c", (int)tmp);
2259 if (PL_expect == XOPERATOR)
2264 else if (*s == '>') {
2267 if (isIDFIRST_lazy(s)) {
2268 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2276 if (PL_expect == XOPERATOR)
2279 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2281 OPERATOR('-'); /* unary minus */
2288 if (PL_expect == XOPERATOR)
2293 if (PL_expect == XOPERATOR)
2296 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2302 if (PL_expect != XOPERATOR) {
2303 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2304 PL_expect = XOPERATOR;
2305 force_ident(PL_tokenbuf, '*');
2318 if (PL_expect == XOPERATOR) {
2322 PL_tokenbuf[0] = '%';
2323 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2324 if (!PL_tokenbuf[1]) {
2326 yyerror("Final % should be \\% or %name");
2329 PL_pending_ident = '%';
2351 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2352 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2357 if (PL_curcop->cop_line < PL_copline)
2358 PL_copline = PL_curcop->cop_line;
2369 if (PL_lex_brackets <= 0)
2370 yyerror("Unmatched right bracket");
2373 if (PL_lex_state == LEX_INTERPNORMAL) {
2374 if (PL_lex_brackets == 0) {
2375 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2376 PL_lex_state = LEX_INTERPEND;
2383 if (PL_lex_brackets > 100) {
2384 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2385 if (newlb != PL_lex_brackstack) {
2387 PL_lex_brackstack = newlb;
2390 switch (PL_expect) {
2392 if (PL_lex_formbrack) {
2396 if (PL_oldoldbufptr == PL_last_lop)
2397 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2399 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2400 OPERATOR(HASHBRACK);
2402 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2405 PL_tokenbuf[0] = '\0';
2406 if (d < PL_bufend && *d == '-') {
2407 PL_tokenbuf[0] = '-';
2409 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2412 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2413 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2415 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2418 char minus = (PL_tokenbuf[0] == '-');
2419 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2426 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2430 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2435 if (PL_oldoldbufptr == PL_last_lop)
2436 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2438 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2441 OPERATOR(HASHBRACK);
2442 /* This hack serves to disambiguate a pair of curlies
2443 * as being a block or an anon hash. Normally, expectation
2444 * determines that, but in cases where we're not in a
2445 * position to expect anything in particular (like inside
2446 * eval"") we have to resolve the ambiguity. This code
2447 * covers the case where the first term in the curlies is a
2448 * quoted string. Most other cases need to be explicitly
2449 * disambiguated by prepending a `+' before the opening
2450 * curly in order to force resolution as an anon hash.
2452 * XXX should probably propagate the outer expectation
2453 * into eval"" to rely less on this hack, but that could
2454 * potentially break current behavior of eval"".
2458 if (*s == '\'' || *s == '"' || *s == '`') {
2459 /* common case: get past first string, handling escapes */
2460 for (t++; t < PL_bufend && *t != *s;)
2461 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2465 else if (*s == 'q') {
2468 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2469 && !isALNUM(*t)))) {
2471 char open, close, term;
2474 while (t < PL_bufend && isSPACE(*t))
2478 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2482 for (t++; t < PL_bufend; t++) {
2483 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2485 else if (*t == open)
2489 for (t++; t < PL_bufend; t++) {
2490 if (*t == '\\' && t+1 < PL_bufend)
2492 else if (*t == close && --brackets <= 0)
2494 else if (*t == open)
2500 else if (isIDFIRST_lazy(s)) {
2501 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2503 while (t < PL_bufend && isSPACE(*t))
2505 /* if comma follows first term, call it an anon hash */
2506 /* XXX it could be a comma expression with loop modifiers */
2507 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2508 || (*t == '=' && t[1] == '>')))
2509 OPERATOR(HASHBRACK);
2510 if (PL_expect == XREF)
2511 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2513 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2519 yylval.ival = PL_curcop->cop_line;
2520 if (isSPACE(*s) || *s == '#')
2521 PL_copline = NOLINE; /* invalidate current command line number */
2526 if (PL_lex_brackets <= 0)
2527 yyerror("Unmatched right bracket");
2529 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2530 if (PL_lex_brackets < PL_lex_formbrack)
2531 PL_lex_formbrack = 0;
2532 if (PL_lex_state == LEX_INTERPNORMAL) {
2533 if (PL_lex_brackets == 0) {
2534 if (PL_lex_fakebrack) {
2535 PL_lex_state = LEX_INTERPEND;
2537 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2539 if (*s == '-' && s[1] == '>')
2540 PL_lex_state = LEX_INTERPENDMAYBE;
2541 else if (*s != '[' && *s != '{')
2542 PL_lex_state = LEX_INTERPEND;
2545 if (PL_lex_brackets < PL_lex_fakebrack) {
2547 PL_lex_fakebrack = 0;
2548 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2558 if (PL_expect == XOPERATOR) {
2559 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2560 PL_curcop->cop_line--;
2561 warner(WARN_SEMICOLON, PL_warn_nosemi);
2562 PL_curcop->cop_line++;
2567 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2569 PL_expect = XOPERATOR;
2570 force_ident(PL_tokenbuf, '&');
2574 yylval.ival = (OPpENTERSUB_AMPER<<8);
2593 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2594 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2596 if (PL_expect == XSTATE && isALPHA(tmp) &&
2597 (s == PL_linestart+1 || s[-2] == '\n') )
2599 if (PL_in_eval && !PL_rsfp) {
2604 if (strnEQ(s,"=cut",4)) {
2618 PL_doextract = TRUE;
2621 if (PL_lex_brackets < PL_lex_formbrack) {
2623 #ifdef PERL_STRICT_CR
2624 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2626 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2628 if (*t == '\n' || *t == '#') {
2646 if (PL_expect != XOPERATOR) {
2647 if (s[1] != '<' && !strchr(s,'>'))
2650 s = scan_heredoc(s);
2652 s = scan_inputsymbol(s);
2653 TERM(sublex_start());
2658 SHop(OP_LEFT_SHIFT);
2672 SHop(OP_RIGHT_SHIFT);
2681 if (PL_expect == XOPERATOR) {
2682 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2685 return ','; /* grandfather non-comma-format format */
2689 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2690 if (PL_expect == XOPERATOR)
2691 no_op("Array length", PL_bufptr);
2692 PL_tokenbuf[0] = '@';
2693 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2695 if (!PL_tokenbuf[1])
2697 PL_expect = XOPERATOR;
2698 PL_pending_ident = '#';
2702 if (PL_expect == XOPERATOR)
2703 no_op("Scalar", PL_bufptr);
2704 PL_tokenbuf[0] = '$';
2705 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2706 if (!PL_tokenbuf[1]) {
2708 yyerror("Final $ should be \\$ or $name");
2712 /* This kludge not intended to be bulletproof. */
2713 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2714 yylval.opval = newSVOP(OP_CONST, 0,
2715 newSViv((IV)PL_compiling.cop_arybase));
2716 yylval.opval->op_private = OPpCONST_ARYBASE;
2721 if (PL_lex_state == LEX_NORMAL)
2724 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2727 PL_tokenbuf[0] = '@';
2728 if (ckWARN(WARN_SYNTAX)) {
2730 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2733 PL_bufptr = skipspace(PL_bufptr);
2734 while (t < PL_bufend && *t != ']')
2737 "Multidimensional syntax %.*s not supported",
2738 (t - PL_bufptr) + 1, PL_bufptr);
2742 else if (*s == '{') {
2743 PL_tokenbuf[0] = '%';
2744 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2745 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2747 char tmpbuf[sizeof PL_tokenbuf];
2749 for (t++; isSPACE(*t); t++) ;
2750 if (isIDFIRST_lazy(t)) {
2751 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2752 for (; isSPACE(*t); t++) ;
2753 if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
2755 "You need to quote \"%s\"", tmpbuf);
2761 PL_expect = XOPERATOR;
2762 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2763 bool islop = (PL_last_lop == PL_oldoldbufptr);
2764 if (!islop || PL_last_lop_op == OP_GREPSTART)
2765 PL_expect = XOPERATOR;
2766 else if (strchr("$@\"'`q", *s))
2767 PL_expect = XTERM; /* e.g. print $fh "foo" */
2768 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2769 PL_expect = XTERM; /* e.g. print $fh &sub */
2770 else if (isIDFIRST_lazy(s)) {
2771 char tmpbuf[sizeof PL_tokenbuf];
2772 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2773 if (tmp = keyword(tmpbuf, len)) {
2774 /* binary operators exclude handle interpretations */
2786 PL_expect = XTERM; /* e.g. print $fh length() */
2791 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2792 if (gv && GvCVu(gv))
2793 PL_expect = XTERM; /* e.g. print $fh subr() */
2796 else if (isDIGIT(*s))
2797 PL_expect = XTERM; /* e.g. print $fh 3 */
2798 else if (*s == '.' && isDIGIT(s[1]))
2799 PL_expect = XTERM; /* e.g. print $fh .3 */
2800 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2801 PL_expect = XTERM; /* e.g. print $fh -1 */
2802 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2803 PL_expect = XTERM; /* print $fh <<"EOF" */
2805 PL_pending_ident = '$';
2809 if (PL_expect == XOPERATOR)
2811 PL_tokenbuf[0] = '@';
2812 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2813 if (!PL_tokenbuf[1]) {
2815 yyerror("Final @ should be \\@ or @name");
2818 if (PL_lex_state == LEX_NORMAL)
2820 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2822 PL_tokenbuf[0] = '%';
2824 /* Warn about @ where they meant $. */
2825 if (ckWARN(WARN_SYNTAX)) {
2826 if (*s == '[' || *s == '{') {
2828 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2830 if (*t == '}' || *t == ']') {
2832 PL_bufptr = skipspace(PL_bufptr);
2834 "Scalar value %.*s better written as $%.*s",
2835 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2840 PL_pending_ident = '@';
2843 case '/': /* may either be division or pattern */
2844 case '?': /* may either be conditional or pattern */
2845 if (PL_expect != XOPERATOR) {
2846 /* Disable warning on "study /blah/" */
2847 if (PL_oldoldbufptr == PL_last_uni
2848 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2849 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2851 s = scan_pat(s,OP_MATCH);
2852 TERM(sublex_start());
2860 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2861 #ifdef PERL_STRICT_CR
2864 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2866 && (s == PL_linestart || s[-1] == '\n') )
2868 PL_lex_formbrack = 0;
2872 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2878 yylval.ival = OPf_SPECIAL;
2884 if (PL_expect != XOPERATOR)
2889 case '0': case '1': case '2': case '3': case '4':
2890 case '5': case '6': case '7': case '8': case '9':
2892 if (PL_expect == XOPERATOR)
2898 if (PL_expect == XOPERATOR) {
2899 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2902 return ','; /* grandfather non-comma-format format */
2908 missingterm((char*)0);
2909 yylval.ival = OP_CONST;
2910 TERM(sublex_start());
2914 if (PL_expect == XOPERATOR) {
2915 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2918 return ','; /* grandfather non-comma-format format */
2924 missingterm((char*)0);
2925 yylval.ival = OP_CONST;
2926 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2927 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2928 yylval.ival = OP_STRINGIFY;
2932 TERM(sublex_start());
2936 if (PL_expect == XOPERATOR)
2937 no_op("Backticks",s);
2939 missingterm((char*)0);
2940 yylval.ival = OP_BACKTICK;
2942 TERM(sublex_start());
2946 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2947 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2949 if (PL_expect == XOPERATOR)
2950 no_op("Backslash",s);
2954 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2994 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2996 /* Some keywords can be followed by any delimiter, including ':' */
2997 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2998 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2999 (PL_tokenbuf[0] == 'q' &&
3000 strchr("qwxr", PL_tokenbuf[1]))));
3002 /* x::* is just a word, unless x is "CORE" */
3003 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3007 while (d < PL_bufend && isSPACE(*d))
3008 d++; /* no comments skipped here, or s### is misparsed */
3010 /* Is this a label? */
3011 if (!tmp && PL_expect == XSTATE
3012 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3014 yylval.pval = savepv(PL_tokenbuf);
3019 /* Check for keywords */
3020 tmp = keyword(PL_tokenbuf, len);
3022 /* Is this a word before a => operator? */
3023 if (strnEQ(d,"=>",2)) {
3025 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3026 yylval.opval->op_private = OPpCONST_BARE;
3030 if (tmp < 0) { /* second-class keyword? */
3031 GV *ogv = Nullgv; /* override (winner) */
3032 GV *hgv = Nullgv; /* hidden (loser) */
3033 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3035 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3038 if (GvIMPORTED_CV(gv))
3040 else if (! CvMETHOD(cv))
3044 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3045 (gv = *gvp) != (GV*)&PL_sv_undef &&
3046 GvCVu(gv) && GvIMPORTED_CV(gv))
3052 tmp = 0; /* overridden by import or by GLOBAL */
3055 && -tmp==KEY_lock /* XXX generalizable kludge */
3056 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3058 tmp = 0; /* any sub overrides "weak" keyword */
3060 else { /* no override */
3064 if (ckWARN(WARN_AMBIGUOUS) && hgv
3065 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3066 warner(WARN_AMBIGUOUS,
3067 "Ambiguous call resolved as CORE::%s(), %s",
3068 GvENAME(hgv), "qualify as such or use &");
3075 default: /* not a keyword */
3078 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3080 /* Get the rest if it looks like a package qualifier */
3082 if (*s == '\'' || *s == ':' && s[1] == ':') {
3084 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3087 croak("Bad name after %s%s", PL_tokenbuf,
3088 *s == '\'' ? "'" : "::");
3092 if (PL_expect == XOPERATOR) {
3093 if (PL_bufptr == PL_linestart) {
3094 PL_curcop->cop_line--;
3095 warner(WARN_SEMICOLON, PL_warn_nosemi);
3096 PL_curcop->cop_line++;
3099 no_op("Bareword",s);
3102 /* Look for a subroutine with this name in current package,
3103 unless name is "Foo::", in which case Foo is a bearword
3104 (and a package name). */
3107 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3109 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3111 "Bareword \"%s\" refers to nonexistent package",
3114 PL_tokenbuf[len] = '\0';
3121 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3124 /* if we saw a global override before, get the right name */
3127 sv = newSVpv("CORE::GLOBAL::",14);
3128 sv_catpv(sv,PL_tokenbuf);
3131 sv = newSVpv(PL_tokenbuf,0);
3133 /* Presume this is going to be a bareword of some sort. */
3136 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3137 yylval.opval->op_private = OPpCONST_BARE;
3139 /* And if "Foo::", then that's what it certainly is. */
3144 /* See if it's the indirect object for a list operator. */
3146 if (PL_oldoldbufptr &&
3147 PL_oldoldbufptr < PL_bufptr &&
3148 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3149 /* NO SKIPSPACE BEFORE HERE! */
3151 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3152 || (PL_last_lop_op == OP_ENTERSUB
3154 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3156 bool immediate_paren = *s == '(';
3158 /* (Now we can afford to cross potential line boundary.) */
3161 /* Two barewords in a row may indicate method call. */
3163 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3166 /* If not a declared subroutine, it's an indirect object. */
3167 /* (But it's an indir obj regardless for sort.) */
3169 if ((PL_last_lop_op == OP_SORT ||
3170 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3171 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3172 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3177 /* If followed by a paren, it's certainly a subroutine. */
3179 PL_expect = XOPERATOR;
3183 if (gv && GvCVu(gv)) {
3185 if ((cv = GvCV(gv)) && SvPOK(cv))
3186 PL_last_proto = SvPV((SV*)cv, n_a);
3187 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3188 if (*d == ')' && (sv = cv_const_sv(cv))) {
3193 PL_nextval[PL_nexttoke].opval = yylval.opval;
3194 PL_expect = XOPERATOR;
3197 PL_last_lop_op = OP_ENTERSUB;
3201 /* If followed by var or block, call it a method (unless sub) */
3203 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3204 PL_last_lop = PL_oldbufptr;
3205 PL_last_lop_op = OP_METHOD;
3209 /* If followed by a bareword, see if it looks like indir obj. */
3211 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3214 /* Not a method, so call it a subroutine (if defined) */
3216 if (gv && GvCVu(gv)) {
3218 if (lastchar == '-')
3219 warn("Ambiguous use of -%s resolved as -&%s()",
3220 PL_tokenbuf, PL_tokenbuf);
3221 PL_last_lop = PL_oldbufptr;
3222 PL_last_lop_op = OP_ENTERSUB;
3223 /* Check for a constant sub */
3225 if ((sv = cv_const_sv(cv))) {
3227 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3228 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3229 yylval.opval->op_private = 0;
3233 /* Resolve to GV now. */
3234 op_free(yylval.opval);
3235 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3236 PL_last_lop_op = OP_ENTERSUB;
3237 /* Is there a prototype? */
3240 PL_last_proto = SvPV((SV*)cv, len);
3243 if (strEQ(PL_last_proto, "$"))
3245 if (*PL_last_proto == '&' && *s == '{') {
3246 sv_setpv(PL_subname,"__ANON__");
3250 PL_last_proto = NULL;
3251 PL_nextval[PL_nexttoke].opval = yylval.opval;
3257 if (PL_hints & HINT_STRICT_SUBS &&
3260 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3261 PL_last_lop_op != OP_ACCEPT &&
3262 PL_last_lop_op != OP_PIPE_OP &&
3263 PL_last_lop_op != OP_SOCKPAIR &&
3264 !(PL_last_lop_op == OP_ENTERSUB
3266 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3269 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3274 /* Call it a bare word */
3277 if (ckWARN(WARN_RESERVED)) {
3278 if (lastchar != '-') {
3279 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3281 warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
3286 if (lastchar && strchr("*%&", lastchar)) {
3287 warn("Operator or semicolon missing before %c%s",
3288 lastchar, PL_tokenbuf);
3289 warn("Ambiguous use of %c resolved as operator %c",
3290 lastchar, lastchar);
3296 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3297 newSVsv(GvSV(PL_curcop->cop_filegv)));
3301 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3302 newSVpvf("%ld", (long)PL_curcop->cop_line));
3305 case KEY___PACKAGE__:
3306 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3308 ? newSVsv(PL_curstname)
3317 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3318 char *pname = "main";
3319 if (PL_tokenbuf[2] == 'D')
3320 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3321 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3324 GvIOp(gv) = newIO();
3325 IoIFP(GvIOp(gv)) = PL_rsfp;
3326 #if defined(HAS_FCNTL) && defined(F_SETFD)
3328 int fd = PerlIO_fileno(PL_rsfp);
3329 fcntl(fd,F_SETFD,fd >= 3);
3332 /* Mark this internal pseudo-handle as clean */
3333 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3335 IoTYPE(GvIOp(gv)) = '|';
3336 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3337 IoTYPE(GvIOp(gv)) = '-';
3339 IoTYPE(GvIOp(gv)) = '<';
3350 if (PL_expect == XSTATE) {
3357 if (*s == ':' && s[1] == ':') {
3360 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3361 tmp = keyword(PL_tokenbuf, len);
3375 LOP(OP_ACCEPT,XTERM);
3381 LOP(OP_ATAN2,XTERM);
3390 LOP(OP_BLESS,XTERM);
3399 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3416 if (!PL_cryptseen++)
3419 LOP(OP_CRYPT,XTERM);
3422 if (ckWARN(WARN_OCTAL)) {
3423 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3424 if (*d != '0' && isDIGIT(*d))
3425 yywarn("chmod: mode argument is missing initial 0");
3427 LOP(OP_CHMOD,XTERM);
3430 LOP(OP_CHOWN,XTERM);
3433 LOP(OP_CONNECT,XTERM);
3449 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3453 PL_hints |= HINT_BLOCK_SCOPE;
3463 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3464 LOP(OP_DBMOPEN,XTERM);
3470 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3477 yylval.ival = PL_curcop->cop_line;
3491 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3492 UNIBRACK(OP_ENTEREVAL);
3507 case KEY_endhostent:
3513 case KEY_endservent:
3516 case KEY_endprotoent:
3527 yylval.ival = PL_curcop->cop_line;
3529 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3531 if ((PL_bufend - p) >= 3 &&
3532 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3535 if (isIDFIRST_lazy(p))
3536 croak("Missing $ on loop variable");
3541 LOP(OP_FORMLINE,XTERM);
3547 LOP(OP_FCNTL,XTERM);
3553 LOP(OP_FLOCK,XTERM);
3562 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3565 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3580 case KEY_getpriority:
3581 LOP(OP_GETPRIORITY,XTERM);
3583 case KEY_getprotobyname:
3586 case KEY_getprotobynumber:
3587 LOP(OP_GPBYNUMBER,XTERM);
3589 case KEY_getprotoent:
3601 case KEY_getpeername:
3602 UNI(OP_GETPEERNAME);
3604 case KEY_gethostbyname:
3607 case KEY_gethostbyaddr:
3608 LOP(OP_GHBYADDR,XTERM);
3610 case KEY_gethostent:
3613 case KEY_getnetbyname:
3616 case KEY_getnetbyaddr:
3617 LOP(OP_GNBYADDR,XTERM);
3622 case KEY_getservbyname:
3623 LOP(OP_GSBYNAME,XTERM);
3625 case KEY_getservbyport:
3626 LOP(OP_GSBYPORT,XTERM);
3628 case KEY_getservent:
3631 case KEY_getsockname:
3632 UNI(OP_GETSOCKNAME);
3634 case KEY_getsockopt:
3635 LOP(OP_GSOCKOPT,XTERM);
3657 yylval.ival = PL_curcop->cop_line;
3661 LOP(OP_INDEX,XTERM);
3667 LOP(OP_IOCTL,XTERM);
3679 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3710 LOP(OP_LISTEN,XTERM);
3719 s = scan_pat(s,OP_MATCH);
3720 TERM(sublex_start());
3723 LOP(OP_MAPSTART, XREF);
3726 LOP(OP_MKDIR,XTERM);
3729 LOP(OP_MSGCTL,XTERM);
3732 LOP(OP_MSGGET,XTERM);
3735 LOP(OP_MSGRCV,XTERM);
3738 LOP(OP_MSGSND,XTERM);
3743 if (isIDFIRST_lazy(s)) {
3744 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3745 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3746 if (!PL_in_my_stash) {
3749 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3756 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3763 if (PL_expect != XSTATE)
3764 yyerror("\"no\" not allowed in expression");
3765 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3766 s = force_version(s);
3775 if (isIDFIRST_lazy(s)) {
3777 for (d = s; isALNUM_lazy(d); d++) ;
3779 if (strchr("|&*+-=!?:.", *t))
3780 warn("Precedence problem: open %.*s should be open(%.*s)",
3786 yylval.ival = OP_OR;
3796 LOP(OP_OPEN_DIR,XTERM);
3799 checkcomma(s,PL_tokenbuf,"filehandle");
3803 checkcomma(s,PL_tokenbuf,"filehandle");
3822 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3826 LOP(OP_PIPE_OP,XTERM);
3831 missingterm((char*)0);
3832 yylval.ival = OP_CONST;
3833 TERM(sublex_start());
3841 missingterm((char*)0);
3842 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3843 d = SvPV_force(PL_lex_stuff, len);
3844 for (; len; --len, ++d) {
3847 "Possible attempt to separate words with commas");
3852 "Possible attempt to put comments in qw() list");
3858 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3859 PL_lex_stuff = Nullsv;
3862 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3865 yylval.ival = OP_SPLIT;
3869 PL_last_lop = PL_oldbufptr;
3870 PL_last_lop_op = OP_SPLIT;
3876 missingterm((char*)0);
3877 yylval.ival = OP_STRINGIFY;
3878 if (SvIVX(PL_lex_stuff) == '\'')
3879 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3880 TERM(sublex_start());
3883 s = scan_pat(s,OP_QR);
3884 TERM(sublex_start());
3889 missingterm((char*)0);
3890 yylval.ival = OP_BACKTICK;
3892 TERM(sublex_start());
3898 *PL_tokenbuf = '\0';
3899 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3900 if (isIDFIRST_lazy(PL_tokenbuf))
3901 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3903 yyerror("<> should be quotes");
3910 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3914 LOP(OP_RENAME,XTERM);
3923 LOP(OP_RINDEX,XTERM);
3946 LOP(OP_REVERSE,XTERM);
3957 TERM(sublex_start());
3959 TOKEN(1); /* force error */
3968 LOP(OP_SELECT,XTERM);
3974 LOP(OP_SEMCTL,XTERM);
3977 LOP(OP_SEMGET,XTERM);
3980 LOP(OP_SEMOP,XTERM);
3986 LOP(OP_SETPGRP,XTERM);
3988 case KEY_setpriority:
3989 LOP(OP_SETPRIORITY,XTERM);
3991 case KEY_sethostent:
3997 case KEY_setservent:
4000 case KEY_setprotoent:
4010 LOP(OP_SEEKDIR,XTERM);
4012 case KEY_setsockopt:
4013 LOP(OP_SSOCKOPT,XTERM);
4019 LOP(OP_SHMCTL,XTERM);
4022 LOP(OP_SHMGET,XTERM);
4025 LOP(OP_SHMREAD,XTERM);
4028 LOP(OP_SHMWRITE,XTERM);
4031 LOP(OP_SHUTDOWN,XTERM);
4040 LOP(OP_SOCKET,XTERM);
4042 case KEY_socketpair:
4043 LOP(OP_SOCKPAIR,XTERM);
4046 checkcomma(s,PL_tokenbuf,"subroutine name");
4048 if (*s == ';' || *s == ')') /* probably a close */
4049 croak("sort is now a reserved word");
4051 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4055 LOP(OP_SPLIT,XTERM);
4058 LOP(OP_SPRINTF,XTERM);
4061 LOP(OP_SPLICE,XTERM);
4077 LOP(OP_SUBSTR,XTERM);
4084 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4085 char tmpbuf[sizeof PL_tokenbuf];
4087 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4088 if (strchr(tmpbuf, ':'))
4089 sv_setpv(PL_subname, tmpbuf);
4091 sv_setsv(PL_subname,PL_curstname);
4092 sv_catpvn(PL_subname,"::",2);
4093 sv_catpvn(PL_subname,tmpbuf,len);
4095 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4099 PL_expect = XTERMBLOCK;
4100 sv_setpv(PL_subname,"?");
4103 if (tmp == KEY_format) {
4106 PL_lex_formbrack = PL_lex_brackets + 1;
4110 /* Look for a prototype */
4117 SvREFCNT_dec(PL_lex_stuff);
4118 PL_lex_stuff = Nullsv;
4119 croak("Prototype not terminated");
4122 d = SvPVX(PL_lex_stuff);
4124 for (p = d; *p; ++p) {
4129 SvCUR(PL_lex_stuff) = tmp;
4132 PL_nextval[1] = PL_nextval[0];
4133 PL_nexttype[1] = PL_nexttype[0];
4134 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4135 PL_nexttype[0] = THING;
4136 if (PL_nexttoke == 1) {
4137 PL_lex_defer = PL_lex_state;
4138 PL_lex_expect = PL_expect;
4139 PL_lex_state = LEX_KNOWNEXT;
4141 PL_lex_stuff = Nullsv;
4144 if (*SvPV(PL_subname,n_a) == '?') {
4145 sv_setpv(PL_subname,"__ANON__");
4152 LOP(OP_SYSTEM,XREF);
4155 LOP(OP_SYMLINK,XTERM);
4158 LOP(OP_SYSCALL,XTERM);
4161 LOP(OP_SYSOPEN,XTERM);
4164 LOP(OP_SYSSEEK,XTERM);
4167 LOP(OP_SYSREAD,XTERM);
4170 LOP(OP_SYSWRITE,XTERM);
4174 TERM(sublex_start());
4195 LOP(OP_TRUNCATE,XTERM);
4207 yylval.ival = PL_curcop->cop_line;
4211 yylval.ival = PL_curcop->cop_line;
4215 LOP(OP_UNLINK,XTERM);
4221 LOP(OP_UNPACK,XTERM);
4224 LOP(OP_UTIME,XTERM);
4227 if (ckWARN(WARN_OCTAL)) {
4228 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4229 if (*d != '0' && isDIGIT(*d))
4230 yywarn("umask: argument is missing initial 0");
4235 LOP(OP_UNSHIFT,XTERM);
4238 if (PL_expect != XSTATE)
4239 yyerror("\"use\" not allowed in expression");
4242 s = force_version(s);
4243 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4244 PL_nextval[PL_nexttoke].opval = Nullop;
4249 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4250 s = force_version(s);
4263 yylval.ival = PL_curcop->cop_line;
4267 PL_hints |= HINT_BLOCK_SCOPE;
4274 LOP(OP_WAITPID,XTERM);
4282 static char ctl_l[2];
4284 if (ctl_l[0] == '\0')
4285 ctl_l[0] = toCTRL('L');
4286 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4289 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4294 if (PL_expect == XOPERATOR)
4300 yylval.ival = OP_XOR;
4305 TERM(sublex_start());
4311 keyword(register char *d, I32 len)
4316 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4317 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4318 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4319 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4320 if (strEQ(d,"__END__")) return KEY___END__;
4324 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4329 if (strEQ(d,"and")) return -KEY_and;
4330 if (strEQ(d,"abs")) return -KEY_abs;
4333 if (strEQ(d,"alarm")) return -KEY_alarm;
4334 if (strEQ(d,"atan2")) return -KEY_atan2;
4337 if (strEQ(d,"accept")) return -KEY_accept;
4342 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4345 if (strEQ(d,"bless")) return -KEY_bless;
4346 if (strEQ(d,"bind")) return -KEY_bind;
4347 if (strEQ(d,"binmode")) return -KEY_binmode;
4350 if (strEQ(d,"CORE")) return -KEY_CORE;
4355 if (strEQ(d,"cmp")) return -KEY_cmp;
4356 if (strEQ(d,"chr")) return -KEY_chr;
4357 if (strEQ(d,"cos")) return -KEY_cos;
4360 if (strEQ(d,"chop")) return KEY_chop;
4363 if (strEQ(d,"close")) return -KEY_close;
4364 if (strEQ(d,"chdir")) return -KEY_chdir;
4365 if (strEQ(d,"chomp")) return KEY_chomp;
4366 if (strEQ(d,"chmod")) return -KEY_chmod;
4367 if (strEQ(d,"chown")) return -KEY_chown;
4368 if (strEQ(d,"crypt")) return -KEY_crypt;
4371 if (strEQ(d,"chroot")) return -KEY_chroot;
4372 if (strEQ(d,"caller")) return -KEY_caller;
4375 if (strEQ(d,"connect")) return -KEY_connect;
4378 if (strEQ(d,"closedir")) return -KEY_closedir;
4379 if (strEQ(d,"continue")) return -KEY_continue;
4384 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4389 if (strEQ(d,"do")) return KEY_do;
4392 if (strEQ(d,"die")) return -KEY_die;
4395 if (strEQ(d,"dump")) return -KEY_dump;
4398 if (strEQ(d,"delete")) return KEY_delete;
4401 if (strEQ(d,"defined")) return KEY_defined;
4402 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4405 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4410 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4411 if (strEQ(d,"END")) return KEY_END;
4416 if (strEQ(d,"eq")) return -KEY_eq;
4419 if (strEQ(d,"eof")) return -KEY_eof;
4420 if (strEQ(d,"exp")) return -KEY_exp;
4423 if (strEQ(d,"else")) return KEY_else;
4424 if (strEQ(d,"exit")) return -KEY_exit;
4425 if (strEQ(d,"eval")) return KEY_eval;
4426 if (strEQ(d,"exec")) return -KEY_exec;
4427 if (strEQ(d,"each")) return KEY_each;
4430 if (strEQ(d,"elsif")) return KEY_elsif;
4433 if (strEQ(d,"exists")) return KEY_exists;
4434 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4437 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4438 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4441 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4444 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4445 if (strEQ(d,"endservent")) return -KEY_endservent;
4448 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4455 if (strEQ(d,"for")) return KEY_for;
4458 if (strEQ(d,"fork")) return -KEY_fork;
4461 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4462 if (strEQ(d,"flock")) return -KEY_flock;
4465 if (strEQ(d,"format")) return KEY_format;
4466 if (strEQ(d,"fileno")) return -KEY_fileno;
4469 if (strEQ(d,"foreach")) return KEY_foreach;
4472 if (strEQ(d,"formline")) return -KEY_formline;
4478 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4479 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4483 if (strnEQ(d,"get",3)) {
4488 if (strEQ(d,"ppid")) return -KEY_getppid;
4489 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4492 if (strEQ(d,"pwent")) return -KEY_getpwent;
4493 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4494 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4497 if (strEQ(d,"peername")) return -KEY_getpeername;
4498 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4499 if (strEQ(d,"priority")) return -KEY_getpriority;
4502 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4505 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4509 else if (*d == 'h') {
4510 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4511 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4512 if (strEQ(d,"hostent")) return -KEY_gethostent;
4514 else if (*d == 'n') {
4515 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4516 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4517 if (strEQ(d,"netent")) return -KEY_getnetent;
4519 else if (*d == 's') {
4520 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4521 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4522 if (strEQ(d,"servent")) return -KEY_getservent;
4523 if (strEQ(d,"sockname")) return -KEY_getsockname;
4524 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4526 else if (*d == 'g') {
4527 if (strEQ(d,"grent")) return -KEY_getgrent;
4528 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4529 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4531 else if (*d == 'l') {
4532 if (strEQ(d,"login")) return -KEY_getlogin;
4534 else if (strEQ(d,"c")) return -KEY_getc;
4539 if (strEQ(d,"gt")) return -KEY_gt;
4540 if (strEQ(d,"ge")) return -KEY_ge;
4543 if (strEQ(d,"grep")) return KEY_grep;
4544 if (strEQ(d,"goto")) return KEY_goto;
4545 if (strEQ(d,"glob")) return KEY_glob;
4548 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4553 if (strEQ(d,"hex")) return -KEY_hex;
4556 if (strEQ(d,"INIT")) return KEY_INIT;
4561 if (strEQ(d,"if")) return KEY_if;
4564 if (strEQ(d,"int")) return -KEY_int;
4567 if (strEQ(d,"index")) return -KEY_index;
4568 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4573 if (strEQ(d,"join")) return -KEY_join;
4577 if (strEQ(d,"keys")) return KEY_keys;
4578 if (strEQ(d,"kill")) return -KEY_kill;
4583 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4584 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4590 if (strEQ(d,"lt")) return -KEY_lt;
4591 if (strEQ(d,"le")) return -KEY_le;
4592 if (strEQ(d,"lc")) return -KEY_lc;
4595 if (strEQ(d,"log")) return -KEY_log;
4598 if (strEQ(d,"last")) return KEY_last;
4599 if (strEQ(d,"link")) return -KEY_link;
4600 if (strEQ(d,"lock")) return -KEY_lock;
4603 if (strEQ(d,"local")) return KEY_local;
4604 if (strEQ(d,"lstat")) return -KEY_lstat;
4607 if (strEQ(d,"length")) return -KEY_length;
4608 if (strEQ(d,"listen")) return -KEY_listen;
4611 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4614 if (strEQ(d,"localtime")) return -KEY_localtime;
4620 case 1: return KEY_m;
4622 if (strEQ(d,"my")) return KEY_my;
4625 if (strEQ(d,"map")) return KEY_map;
4628 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4631 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4632 if (strEQ(d,"msgget")) return -KEY_msgget;
4633 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4634 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4639 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4642 if (strEQ(d,"next")) return KEY_next;
4643 if (strEQ(d,"ne")) return -KEY_ne;
4644 if (strEQ(d,"not")) return -KEY_not;
4645 if (strEQ(d,"no")) return KEY_no;
4650 if (strEQ(d,"or")) return -KEY_or;
4653 if (strEQ(d,"ord")) return -KEY_ord;
4654 if (strEQ(d,"oct")) return -KEY_oct;
4655 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4659 if (strEQ(d,"open")) return -KEY_open;
4662 if (strEQ(d,"opendir")) return -KEY_opendir;
4669 if (strEQ(d,"pop")) return KEY_pop;
4670 if (strEQ(d,"pos")) return KEY_pos;
4673 if (strEQ(d,"push")) return KEY_push;
4674 if (strEQ(d,"pack")) return -KEY_pack;
4675 if (strEQ(d,"pipe")) return -KEY_pipe;
4678 if (strEQ(d,"print")) return KEY_print;
4681 if (strEQ(d,"printf")) return KEY_printf;
4684 if (strEQ(d,"package")) return KEY_package;
4687 if (strEQ(d,"prototype")) return KEY_prototype;
4692 if (strEQ(d,"q")) return KEY_q;
4693 if (strEQ(d,"qr")) return KEY_qr;
4694 if (strEQ(d,"qq")) return KEY_qq;
4695 if (strEQ(d,"qw")) return KEY_qw;
4696 if (strEQ(d,"qx")) return KEY_qx;
4698 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4703 if (strEQ(d,"ref")) return -KEY_ref;
4706 if (strEQ(d,"read")) return -KEY_read;
4707 if (strEQ(d,"rand")) return -KEY_rand;
4708 if (strEQ(d,"recv")) return -KEY_recv;
4709 if (strEQ(d,"redo")) return KEY_redo;
4712 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4713 if (strEQ(d,"reset")) return -KEY_reset;
4716 if (strEQ(d,"return")) return KEY_return;
4717 if (strEQ(d,"rename")) return -KEY_rename;
4718 if (strEQ(d,"rindex")) return -KEY_rindex;
4721 if (strEQ(d,"require")) return -KEY_require;
4722 if (strEQ(d,"reverse")) return -KEY_reverse;
4723 if (strEQ(d,"readdir")) return -KEY_readdir;
4726 if (strEQ(d,"readlink")) return -KEY_readlink;
4727 if (strEQ(d,"readline")) return -KEY_readline;
4728 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4731 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4737 case 0: return KEY_s;
4739 if (strEQ(d,"scalar")) return KEY_scalar;
4744 if (strEQ(d,"seek")) return -KEY_seek;
4745 if (strEQ(d,"send")) return -KEY_send;
4748 if (strEQ(d,"semop")) return -KEY_semop;
4751 if (strEQ(d,"select")) return -KEY_select;
4752 if (strEQ(d,"semctl")) return -KEY_semctl;
4753 if (strEQ(d,"semget")) return -KEY_semget;
4756 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4757 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4760 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4761 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4764 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4767 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4768 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4769 if (strEQ(d,"setservent")) return -KEY_setservent;
4772 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4773 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4780 if (strEQ(d,"shift")) return KEY_shift;
4783 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4784 if (strEQ(d,"shmget")) return -KEY_shmget;
4787 if (strEQ(d,"shmread")) return -KEY_shmread;
4790 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4791 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4796 if (strEQ(d,"sin")) return -KEY_sin;
4799 if (strEQ(d,"sleep")) return -KEY_sleep;
4802 if (strEQ(d,"sort")) return KEY_sort;
4803 if (strEQ(d,"socket")) return -KEY_socket;
4804 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4807 if (strEQ(d,"split")) return KEY_split;
4808 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4809 if (strEQ(d,"splice")) return KEY_splice;
4812 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4815 if (strEQ(d,"srand")) return -KEY_srand;
4818 if (strEQ(d,"stat")) return -KEY_stat;
4819 if (strEQ(d,"study")) return KEY_study;
4822 if (strEQ(d,"substr")) return -KEY_substr;
4823 if (strEQ(d,"sub")) return KEY_sub;
4828 if (strEQ(d,"system")) return -KEY_system;
4831 if (strEQ(d,"symlink")) return -KEY_symlink;
4832 if (strEQ(d,"syscall")) return -KEY_syscall;
4833 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4834 if (strEQ(d,"sysread")) return -KEY_sysread;
4835 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4838 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4847 if (strEQ(d,"tr")) return KEY_tr;
4850 if (strEQ(d,"tie")) return KEY_tie;
4853 if (strEQ(d,"tell")) return -KEY_tell;
4854 if (strEQ(d,"tied")) return KEY_tied;
4855 if (strEQ(d,"time")) return -KEY_time;
4858 if (strEQ(d,"times")) return -KEY_times;
4861 if (strEQ(d,"telldir")) return -KEY_telldir;
4864 if (strEQ(d,"truncate")) return -KEY_truncate;
4871 if (strEQ(d,"uc")) return -KEY_uc;
4874 if (strEQ(d,"use")) return KEY_use;
4877 if (strEQ(d,"undef")) return KEY_undef;
4878 if (strEQ(d,"until")) return KEY_until;
4879 if (strEQ(d,"untie")) return KEY_untie;
4880 if (strEQ(d,"utime")) return -KEY_utime;
4881 if (strEQ(d,"umask")) return -KEY_umask;
4884 if (strEQ(d,"unless")) return KEY_unless;
4885 if (strEQ(d,"unpack")) return -KEY_unpack;
4886 if (strEQ(d,"unlink")) return -KEY_unlink;
4889 if (strEQ(d,"unshift")) return KEY_unshift;
4890 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4895 if (strEQ(d,"values")) return -KEY_values;
4896 if (strEQ(d,"vec")) return -KEY_vec;
4901 if (strEQ(d,"warn")) return -KEY_warn;
4902 if (strEQ(d,"wait")) return -KEY_wait;
4905 if (strEQ(d,"while")) return KEY_while;
4906 if (strEQ(d,"write")) return -KEY_write;
4909 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4912 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4917 if (len == 1) return -KEY_x;
4918 if (strEQ(d,"xor")) return -KEY_xor;
4921 if (len == 1) return KEY_y;
4930 checkcomma(register char *s, char *name, char *what)
4934 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4935 dTHR; /* only for ckWARN */
4936 if (ckWARN(WARN_SYNTAX)) {
4938 for (w = s+2; *w && level; w++) {
4945 for (; *w && isSPACE(*w); w++) ;
4946 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4947 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4950 while (s < PL_bufend && isSPACE(*s))
4954 while (s < PL_bufend && isSPACE(*s))
4956 if (isIDFIRST_lazy(s)) {
4958 while (isALNUM_lazy(s))
4960 while (s < PL_bufend && isSPACE(*s))
4965 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4969 croak("No comma allowed after %s", what);
4975 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4978 HV *table = GvHV(PL_hintgv); /* ^H */
4981 bool oldcatch = CATCH_GET;
4986 yyerror("%^H is not defined");
4989 cvp = hv_fetch(table, key, strlen(key), FALSE);
4990 if (!cvp || !SvOK(*cvp)) {
4992 sprintf(buf,"$^H{%s} is not defined", key);
4996 sv_2mortal(sv); /* Parent created it permanently */
4999 pv = sv_2mortal(newSVpv(s, len));
5001 typesv = sv_2mortal(newSVpv(type, 0));
5003 typesv = &PL_sv_undef;
5005 Zero(&myop, 1, BINOP);
5006 myop.op_last = (OP *) &myop;
5007 myop.op_next = Nullop;
5008 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
5010 PUSHSTACKi(PERLSI_OVERLOAD);
5013 PL_op = (OP *) &myop;
5014 if (PERLDB_SUB && PL_curstash != PL_debstash)
5015 PL_op->op_private |= OPpENTERSUB_DB;
5026 if (PL_op = pp_entersub(ARGS))
5033 CATCH_SET(oldcatch);
5038 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5041 return SvREFCNT_inc(res);
5045 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5047 register char *d = dest;
5048 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5051 croak(ident_too_long);
5052 if (isALNUM(*s)) /* UTF handled below */
5054 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5059 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5063 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5064 char *t = s + UTF8SKIP(s);
5065 while (*t & 0x80 && is_utf8_mark((U8*)t))
5067 if (d + (t - s) > e)
5068 croak(ident_too_long);
5069 Copy(s, d, t - s, char);
5082 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5089 if (PL_lex_brackets == 0)
5090 PL_lex_fakebrack = 0;
5094 e = d + destlen - 3; /* two-character token, ending NUL */
5096 while (isDIGIT(*s)) {
5098 croak(ident_too_long);
5105 croak(ident_too_long);
5106 if (isALNUM(*s)) /* UTF handled below */
5108 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5113 else if (*s == ':' && s[1] == ':') {
5117 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5118 char *t = s + UTF8SKIP(s);
5119 while (*t & 0x80 && is_utf8_mark((U8*)t))
5121 if (d + (t - s) > e)
5122 croak(ident_too_long);
5123 Copy(s, d, t - s, char);
5134 if (PL_lex_state != LEX_NORMAL)
5135 PL_lex_state = LEX_INTERPENDMAYBE;
5138 if (*s == '$' && s[1] &&
5139 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5152 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5157 if (isSPACE(s[-1])) {
5160 if (ch != ' ' && ch != '\t') {
5166 if (isIDFIRST_lazy(d)) {
5170 while (e < send && isALNUM_lazy(e) || *e == ':') {
5172 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5175 Copy(s, d, e - s, char);
5180 while (isALNUM(*s) || *s == ':')
5184 while (s < send && (*s == ' ' || *s == '\t')) s++;
5185 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5186 dTHR; /* only for ckWARN */
5187 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5188 char *brack = *s == '[' ? "[...]" : "{...}";
5189 warner(WARN_AMBIGUOUS,
5190 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5191 funny, dest, brack, funny, dest, brack);
5193 PL_lex_fakebrack = PL_lex_brackets+1;
5195 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5201 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5202 PL_lex_state = LEX_INTERPEND;
5205 if (PL_lex_state == LEX_NORMAL) {
5206 dTHR; /* only for ckWARN */
5207 if (ckWARN(WARN_AMBIGUOUS) &&
5208 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5210 warner(WARN_AMBIGUOUS,
5211 "Ambiguous use of %c{%s} resolved to %c%s",
5212 funny, dest, funny, dest);
5217 s = bracket; /* let the parser handle it */
5221 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5222 PL_lex_state = LEX_INTERPEND;
5226 void pmflag(U16 *pmfl, int ch)
5231 *pmfl |= PMf_GLOBAL;
5233 *pmfl |= PMf_CONTINUE;
5237 *pmfl |= PMf_MULTILINE;
5239 *pmfl |= PMf_SINGLELINE;
5241 *pmfl |= PMf_EXTENDED;
5245 scan_pat(char *start, I32 type)
5250 s = scan_str(start);
5253 SvREFCNT_dec(PL_lex_stuff);
5254 PL_lex_stuff = Nullsv;
5255 croak("Search pattern not terminated");
5258 pm = (PMOP*)newPMOP(type, 0);
5259 if (PL_multi_open == '?')
5260 pm->op_pmflags |= PMf_ONCE;
5262 while (*s && strchr("iomsx", *s))
5263 pmflag(&pm->op_pmflags,*s++);
5266 while (*s && strchr("iogcmsx", *s))
5267 pmflag(&pm->op_pmflags,*s++);
5269 pm->op_pmpermflags = pm->op_pmflags;
5271 PL_lex_op = (OP*)pm;
5272 yylval.ival = OP_MATCH;
5277 scan_subst(char *start)
5284 yylval.ival = OP_NULL;
5286 s = scan_str(start);
5290 SvREFCNT_dec(PL_lex_stuff);
5291 PL_lex_stuff = Nullsv;
5292 croak("Substitution pattern not terminated");
5295 if (s[-1] == PL_multi_open)
5298 first_start = PL_multi_start;
5302 SvREFCNT_dec(PL_lex_stuff);
5303 PL_lex_stuff = Nullsv;
5305 SvREFCNT_dec(PL_lex_repl);
5306 PL_lex_repl = Nullsv;
5307 croak("Substitution replacement not terminated");
5309 PL_multi_start = first_start; /* so whole substitution is taken together */
5311 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5317 else if (strchr("iogcmsx", *s))
5318 pmflag(&pm->op_pmflags,*s++);
5325 pm->op_pmflags |= PMf_EVAL;
5326 repl = newSVpv("",0);
5328 sv_catpv(repl, es ? "eval " : "do ");
5329 sv_catpvn(repl, "{ ", 2);
5330 sv_catsv(repl, PL_lex_repl);
5331 sv_catpvn(repl, " };", 2);
5332 SvCOMPILED_on(repl);
5333 SvREFCNT_dec(PL_lex_repl);
5337 pm->op_pmpermflags = pm->op_pmflags;
5338 PL_lex_op = (OP*)pm;
5339 yylval.ival = OP_SUBST;
5344 scan_trans(char *start)
5355 yylval.ival = OP_NULL;
5357 s = scan_str(start);
5360 SvREFCNT_dec(PL_lex_stuff);
5361 PL_lex_stuff = Nullsv;
5362 croak("Transliteration pattern not terminated");
5364 if (s[-1] == PL_multi_open)
5370 SvREFCNT_dec(PL_lex_stuff);
5371 PL_lex_stuff = Nullsv;
5373 SvREFCNT_dec(PL_lex_repl);
5374 PL_lex_repl = Nullsv;
5375 croak("Transliteration replacement not terminated");
5379 o = newSVOP(OP_TRANS, 0, 0);
5380 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5383 New(803,tbl,256,short);
5384 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5388 complement = del = squash = 0;
5389 while (strchr("cdsCU", *s)) {
5391 complement = OPpTRANS_COMPLEMENT;
5393 del = OPpTRANS_DELETE;
5395 squash = OPpTRANS_SQUASH;
5400 utf8 &= ~OPpTRANS_FROM_UTF;
5402 utf8 |= OPpTRANS_FROM_UTF;
5406 utf8 &= ~OPpTRANS_TO_UTF;
5408 utf8 |= OPpTRANS_TO_UTF;
5411 croak("Too many /C and /U options");
5416 o->op_private = del|squash|complement|utf8;
5419 yylval.ival = OP_TRANS;
5424 scan_heredoc(register char *s)
5428 I32 op_type = OP_SCALAR;
5435 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5439 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5442 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5443 if (*peek && strchr("`'\"",*peek)) {
5446 s = delimcpy(d, e, s, PL_bufend, term, &len);
5456 if (!isALNUM_lazy(s))
5457 deprecate("bare << to mean <<\"\"");
5458 for (; isALNUM_lazy(s); s++) {
5463 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5464 croak("Delimiter for here document is too long");
5467 len = d - PL_tokenbuf;
5468 #ifndef PERL_STRICT_CR
5469 d = strchr(s, '\r');
5473 while (s < PL_bufend) {
5479 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5488 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5493 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5494 herewas = newSVpv(s,PL_bufend-s);
5496 s--, herewas = newSVpv(s,d-s);
5497 s += SvCUR(herewas);
5499 tmpstr = NEWSV(87,79);
5500 sv_upgrade(tmpstr, SVt_PVIV);
5505 else if (term == '`') {
5506 op_type = OP_BACKTICK;
5507 SvIVX(tmpstr) = '\\';
5511 PL_multi_start = PL_curcop->cop_line;
5512 PL_multi_open = PL_multi_close = '<';
5513 term = *PL_tokenbuf;
5516 while (s < PL_bufend &&
5517 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5519 PL_curcop->cop_line++;
5521 if (s >= PL_bufend) {
5522 PL_curcop->cop_line = PL_multi_start;
5523 missingterm(PL_tokenbuf);
5525 sv_setpvn(tmpstr,d+1,s-d);
5527 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5529 sv_catpvn(herewas,s,PL_bufend-s);
5530 sv_setsv(PL_linestr,herewas);
5531 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5532 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5535 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5536 while (s >= PL_bufend) { /* multiple line string? */
5538 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5539 PL_curcop->cop_line = PL_multi_start;
5540 missingterm(PL_tokenbuf);
5542 PL_curcop->cop_line++;
5543 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5544 #ifndef PERL_STRICT_CR
5545 if (PL_bufend - PL_linestart >= 2) {
5546 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5547 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5549 PL_bufend[-2] = '\n';
5551 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5553 else if (PL_bufend[-1] == '\r')
5554 PL_bufend[-1] = '\n';
5556 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5557 PL_bufend[-1] = '\n';
5559 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5560 SV *sv = NEWSV(88,0);
5562 sv_upgrade(sv, SVt_PVMG);
5563 sv_setsv(sv,PL_linestr);
5564 av_store(GvAV(PL_curcop->cop_filegv),
5565 (I32)PL_curcop->cop_line,sv);
5567 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5570 sv_catsv(PL_linestr,herewas);
5571 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5575 sv_catsv(tmpstr,PL_linestr);
5578 PL_multi_end = PL_curcop->cop_line;
5580 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5581 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5582 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5584 SvREFCNT_dec(herewas);
5585 PL_lex_stuff = tmpstr;
5586 yylval.ival = op_type;
5591 takes: current position in input buffer
5592 returns: new position in input buffer
5593 side-effects: yylval and lex_op are set.
5598 <FH> read from filehandle
5599 <pkg::FH> read from package qualified filehandle
5600 <pkg'FH> read from package qualified filehandle
5601 <$fh> read from filehandle in $fh
5607 scan_inputsymbol(char *start)
5609 register char *s = start; /* current position in buffer */
5614 d = PL_tokenbuf; /* start of temp holding space */
5615 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5616 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5618 /* die if we didn't have space for the contents of the <>,
5622 if (len >= sizeof PL_tokenbuf)
5623 croak("Excessively long <> operator");
5625 croak("Unterminated <> operator");
5630 Remember, only scalar variables are interpreted as filehandles by
5631 this code. Anything more complex (e.g., <$fh{$num}>) will be
5632 treated as a glob() call.
5633 This code makes use of the fact that except for the $ at the front,
5634 a scalar variable and a filehandle look the same.
5636 if (*d == '$' && d[1]) d++;
5638 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5639 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5642 /* If we've tried to read what we allow filehandles to look like, and
5643 there's still text left, then it must be a glob() and not a getline.
5644 Use scan_str to pull out the stuff between the <> and treat it
5645 as nothing more than a string.
5648 if (d - PL_tokenbuf != len) {
5649 yylval.ival = OP_GLOB;
5651 s = scan_str(start);
5653 croak("Glob not terminated");
5657 /* we're in a filehandle read situation */
5660 /* turn <> into <ARGV> */
5662 (void)strcpy(d,"ARGV");
5664 /* if <$fh>, create the ops to turn the variable into a
5670 /* try to find it in the pad for this block, otherwise find
5671 add symbol table ops
5673 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5674 OP *o = newOP(OP_PADSV, 0);
5676 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5679 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5680 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5681 newUNOP(OP_RV2SV, 0,
5682 newGVOP(OP_GV, 0, gv)));
5684 PL_lex_op->op_flags |= OPf_SPECIAL;
5685 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5686 yylval.ival = OP_NULL;
5689 /* If it's none of the above, it must be a literal filehandle
5690 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5692 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5693 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5694 yylval.ival = OP_NULL;
5703 takes: start position in buffer
5704 returns: position to continue reading from buffer
5705 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5706 updates the read buffer.
5708 This subroutine pulls a string out of the input. It is called for:
5709 q single quotes q(literal text)
5710 ' single quotes 'literal text'
5711 qq double quotes qq(interpolate $here please)
5712 " double quotes "interpolate $here please"
5713 qx backticks qx(/bin/ls -l)
5714 ` backticks `/bin/ls -l`
5715 qw quote words @EXPORT_OK = qw( func() $spam )
5716 m// regexp match m/this/
5717 s/// regexp substitute s/this/that/
5718 tr/// string transliterate tr/this/that/
5719 y/// string transliterate y/this/that/
5720 ($*@) sub prototypes sub foo ($)
5721 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5723 In most of these cases (all but <>, patterns and transliterate)
5724 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5725 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5726 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5729 It skips whitespace before the string starts, and treats the first
5730 character as the delimiter. If the delimiter is one of ([{< then
5731 the corresponding "close" character )]}> is used as the closing
5732 delimiter. It allows quoting of delimiters, and if the string has
5733 balanced delimiters ([{<>}]) it allows nesting.
5735 The lexer always reads these strings into lex_stuff, except in the
5736 case of the operators which take *two* arguments (s/// and tr///)
5737 when it checks to see if lex_stuff is full (presumably with the 1st
5738 arg to s or tr) and if so puts the string into lex_repl.
5743 scan_str(char *start)
5746 SV *sv; /* scalar value: string */
5747 char *tmps; /* temp string, used for delimiter matching */
5748 register char *s = start; /* current position in the buffer */
5749 register char term; /* terminating character */
5750 register char *to; /* current position in the sv's data */
5751 I32 brackets = 1; /* bracket nesting level */
5753 /* skip space before the delimiter */
5757 /* mark where we are, in case we need to report errors */
5760 /* after skipping whitespace, the next character is the terminator */
5762 /* mark where we are */
5763 PL_multi_start = PL_curcop->cop_line;
5764 PL_multi_open = term;
5766 /* find corresponding closing delimiter */
5767 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5769 PL_multi_close = term;
5771 /* create a new SV to hold the contents. 87 is leak category, I'm
5772 assuming. 79 is the SV's initial length. What a random number. */
5774 sv_upgrade(sv, SVt_PVIV);
5776 (void)SvPOK_only(sv); /* validate pointer */
5778 /* move past delimiter and try to read a complete string */
5781 /* extend sv if need be */
5782 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5783 /* set 'to' to the next character in the sv's string */
5784 to = SvPVX(sv)+SvCUR(sv);
5786 /* if open delimiter is the close delimiter read unbridle */
5787 if (PL_multi_open == PL_multi_close) {
5788 for (; s < PL_bufend; s++,to++) {
5789 /* embedded newlines increment the current line number */
5790 if (*s == '\n' && !PL_rsfp)
5791 PL_curcop->cop_line++;
5792 /* handle quoted delimiters */
5793 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5796 /* any other quotes are simply copied straight through */
5800 /* terminate when run out of buffer (the for() condition), or
5801 have found the terminator */
5802 else if (*s == term)
5808 /* if the terminator isn't the same as the start character (e.g.,
5809 matched brackets), we have to allow more in the quoting, and
5810 be prepared for nested brackets.
5813 /* read until we run out of string, or we find the terminator */
5814 for (; s < PL_bufend; s++,to++) {
5815 /* embedded newlines increment the line count */
5816 if (*s == '\n' && !PL_rsfp)
5817 PL_curcop->cop_line++;
5818 /* backslashes can escape the open or closing characters */
5819 if (*s == '\\' && s+1 < PL_bufend) {
5820 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5825 /* allow nested opens and closes */
5826 else if (*s == PL_multi_close && --brackets <= 0)
5828 else if (*s == PL_multi_open)
5833 /* terminate the copied string and update the sv's end-of-string */
5835 SvCUR_set(sv, to - SvPVX(sv));
5838 * this next chunk reads more into the buffer if we're not done yet
5841 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5843 #ifndef PERL_STRICT_CR
5844 if (to - SvPVX(sv) >= 2) {
5845 if ((to[-2] == '\r' && to[-1] == '\n') ||
5846 (to[-2] == '\n' && to[-1] == '\r'))
5850 SvCUR_set(sv, to - SvPVX(sv));
5852 else if (to[-1] == '\r')
5855 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5859 /* if we're out of file, or a read fails, bail and reset the current
5860 line marker so we can report where the unterminated string began
5863 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5865 PL_curcop->cop_line = PL_multi_start;
5868 /* we read a line, so increment our line counter */
5869 PL_curcop->cop_line++;
5871 /* update debugger info */
5872 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5873 SV *sv = NEWSV(88,0);
5875 sv_upgrade(sv, SVt_PVMG);
5876 sv_setsv(sv,PL_linestr);
5877 av_store(GvAV(PL_curcop->cop_filegv),
5878 (I32)PL_curcop->cop_line, sv);
5881 /* having changed the buffer, we must update PL_bufend */
5882 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5885 /* at this point, we have successfully read the delimited string */
5887 PL_multi_end = PL_curcop->cop_line;
5890 /* if we allocated too much space, give some back */
5891 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5892 SvLEN_set(sv, SvCUR(sv) + 1);
5893 Renew(SvPVX(sv), SvLEN(sv), char);
5896 /* decide whether this is the first or second quoted string we've read
5909 takes: pointer to position in buffer
5910 returns: pointer to new position in buffer
5911 side-effects: builds ops for the constant in yylval.op
5913 Read a number in any of the formats that Perl accepts:
5915 0(x[0-7A-F]+)|([0-7]+)|(b[01])
5916 [\d_]+(\.[\d_]*)?[Ee](\d+)
5918 Underbars (_) are allowed in decimal numbers. If -w is on,
5919 underbars before a decimal point must be at three digit intervals.
5921 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5924 If it reads a number without a decimal point or an exponent, it will
5925 try converting the number to an integer and see if it can do so
5926 without loss of precision.
5930 scan_num(char *start)
5932 register char *s = start; /* current position in buffer */
5933 register char *d; /* destination in temp buffer */
5934 register char *e; /* end of temp buffer */
5935 I32 tryiv; /* used to see if it can be an int */
5936 double value; /* number read, as a double */
5937 SV *sv; /* place to put the converted number */
5938 I32 floatit; /* boolean: int or float? */
5939 char *lastub = 0; /* position of last underbar */
5940 static char number_too_long[] = "Number too long";
5942 /* We use the first character to decide what type of number this is */
5946 croak("panic: scan_num");
5948 /* if it starts with a 0, it could be an octal number, a decimal in
5949 0.13 disguise, or a hexadecimal number, or a binary number.
5954 u holds the "number so far"
5955 shift the power of 2 of the base
5956 (hex == 4, octal == 3, binary == 1)
5957 overflowed was the number more than we can hold?
5959 Shift is used when we add a digit. It also serves as an "are
5960 we in octal/hex/binary?" indicator to disallow hex characters
5965 bool overflowed = FALSE;
5971 } else if (s[1] == 'b') {
5975 /* check for a decimal in disguise */
5976 else if (s[1] == '.')
5978 /* so it must be octal */
5983 /* read the rest of the number */
5985 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5989 /* if we don't mention it, we're done */
5998 /* 8 and 9 are not octal */
6001 yyerror("Illegal octal digit");
6004 yyerror("Illegal binary digit");
6008 case '2': case '3': case '4':
6009 case '5': case '6': case '7':
6011 yyerror("Illegal binary digit");
6015 b = *s++ & 15; /* ASCII digit -> value of digit */
6019 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6020 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6021 /* make sure they said 0x */
6026 /* Prepare to put the digit we have onto the end
6027 of the number so far. We check for overflows.
6031 n = u << shift; /* make room for the digit */
6032 if (!overflowed && (n >> shift) != u
6033 && !(PL_hints & HINT_NEW_BINARY)) {
6034 warn("Integer overflow in %s number",
6035 (shift == 4) ? "hex"
6036 : ((shift == 3) ? "octal" : "binary"));
6039 u = n | b; /* add the digit to the end */
6044 /* if we get here, we had success: make a scalar value from
6050 if ( PL_hints & HINT_NEW_BINARY)
6051 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6056 handle decimal numbers.
6057 we're also sent here when we read a 0 as the first digit
6059 case '1': case '2': case '3': case '4': case '5':
6060 case '6': case '7': case '8': case '9': case '.':
6063 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6066 /* read next group of digits and _ and copy into d */
6067 while (isDIGIT(*s) || *s == '_') {
6068 /* skip underscores, checking for misplaced ones
6072 dTHR; /* only for ckWARN */
6073 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6074 warner(WARN_SYNTAX, "Misplaced _ in number");
6078 /* check for end of fixed-length buffer */
6080 croak(number_too_long);
6081 /* if we're ok, copy the character */
6086 /* final misplaced underbar check */
6087 if (lastub && s - lastub != 3) {
6089 if (ckWARN(WARN_SYNTAX))
6090 warner(WARN_SYNTAX, "Misplaced _ in number");
6093 /* read a decimal portion if there is one. avoid
6094 3..5 being interpreted as the number 3. followed
6097 if (*s == '.' && s[1] != '.') {
6101 /* copy, ignoring underbars, until we run out of
6102 digits. Note: no misplaced underbar checks!
6104 for (; isDIGIT(*s) || *s == '_'; s++) {
6105 /* fixed length buffer check */
6107 croak(number_too_long);
6113 /* read exponent part, if present */
6114 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6118 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6119 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6121 /* allow positive or negative exponent */
6122 if (*s == '+' || *s == '-')
6125 /* read digits of exponent (no underbars :-) */
6126 while (isDIGIT(*s)) {
6128 croak(number_too_long);
6133 /* terminate the string */
6136 /* make an sv from the string */
6138 /* reset numeric locale in case we were earlier left in Swaziland */
6139 SET_NUMERIC_STANDARD();
6140 value = atof(PL_tokenbuf);
6143 See if we can make do with an integer value without loss of
6144 precision. We use I_V to cast to an int, because some
6145 compilers have issues. Then we try casting it back and see
6146 if it was the same. We only do this if we know we
6147 specifically read an integer.
6149 Note: if floatit is true, then we don't need to do the
6153 if (!floatit && (double)tryiv == value)
6154 sv_setiv(sv, tryiv);
6156 sv_setnv(sv, value);
6157 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6158 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6159 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6163 /* make the op for the constant and return */
6165 yylval.opval = newSVOP(OP_CONST, 0, sv);
6171 scan_formline(register char *s)
6176 SV *stuff = newSVpv("",0);
6177 bool needargs = FALSE;
6180 if (*s == '.' || *s == '}') {
6182 #ifdef PERL_STRICT_CR
6183 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6185 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6187 if (*t == '\n' || t == PL_bufend)
6190 if (PL_in_eval && !PL_rsfp) {
6191 eol = strchr(s,'\n');
6196 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6198 for (t = s; t < eol; t++) {
6199 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6201 goto enough; /* ~~ must be first line in formline */
6203 if (*t == '@' || *t == '^')
6206 sv_catpvn(stuff, s, eol-s);
6210 s = filter_gets(PL_linestr, PL_rsfp, 0);
6211 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6212 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6215 yyerror("Format not terminated");
6225 PL_lex_state = LEX_NORMAL;
6226 PL_nextval[PL_nexttoke].ival = 0;
6230 PL_lex_state = LEX_FORMLINE;
6231 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6233 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6237 SvREFCNT_dec(stuff);
6238 PL_lex_formbrack = 0;
6249 PL_cshlen = strlen(PL_cshname);
6254 start_subparse(I32 is_format, U32 flags)
6257 I32 oldsavestack_ix = PL_savestack_ix;
6258 CV* outsidecv = PL_compcv;
6262 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6264 save_I32(&PL_subline);
6265 save_item(PL_subname);
6267 SAVESPTR(PL_curpad);
6268 SAVESPTR(PL_comppad);
6269 SAVESPTR(PL_comppad_name);
6270 SAVESPTR(PL_compcv);
6271 SAVEI32(PL_comppad_name_fill);
6272 SAVEI32(PL_min_intro_pending);
6273 SAVEI32(PL_max_intro_pending);
6274 SAVEI32(PL_pad_reset_pending);
6276 PL_compcv = (CV*)NEWSV(1104,0);
6277 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6278 CvFLAGS(PL_compcv) |= flags;
6280 PL_comppad = newAV();
6281 av_push(PL_comppad, Nullsv);
6282 PL_curpad = AvARRAY(PL_comppad);
6283 PL_comppad_name = newAV();
6284 PL_comppad_name_fill = 0;
6285 PL_min_intro_pending = 0;
6287 PL_subline = PL_curcop->cop_line;
6289 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6290 PL_curpad[0] = (SV*)newAV();
6291 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6292 #endif /* USE_THREADS */
6294 comppadlist = newAV();
6295 AvREAL_off(comppadlist);
6296 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6297 av_store(comppadlist, 1, (SV*)PL_comppad);
6299 CvPADLIST(PL_compcv) = comppadlist;
6300 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6302 CvOWNER(PL_compcv) = 0;
6303 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6304 MUTEX_INIT(CvMUTEXP(PL_compcv));
6305 #endif /* USE_THREADS */
6307 return oldsavestack_ix;
6326 char *context = NULL;
6330 if (!yychar || (yychar == ';' && !PL_rsfp))
6332 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6333 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6334 while (isSPACE(*PL_oldoldbufptr))
6336 context = PL_oldoldbufptr;
6337 contlen = PL_bufptr - PL_oldoldbufptr;
6339 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6340 PL_oldbufptr != PL_bufptr) {
6341 while (isSPACE(*PL_oldbufptr))
6343 context = PL_oldbufptr;
6344 contlen = PL_bufptr - PL_oldbufptr;
6346 else if (yychar > 255)
6347 where = "next token ???";
6348 else if ((yychar & 127) == 127) {
6349 if (PL_lex_state == LEX_NORMAL ||
6350 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6351 where = "at end of line";
6352 else if (PL_lex_inpat)
6353 where = "within pattern";
6355 where = "within string";
6358 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6360 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6361 else if (isPRINT_LC(yychar))
6362 sv_catpvf(where_sv, "%c", yychar);
6364 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6365 where = SvPVX(where_sv);
6367 msg = sv_2mortal(newSVpv(s, 0));
6368 sv_catpvf(msg, " at %_ line %ld, ",
6369 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6371 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6373 sv_catpvf(msg, "%s\n", where);
6374 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6376 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6377 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6382 else if (PL_in_eval)
6383 sv_catsv(ERRSV, msg);
6385 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6386 if (++PL_error_count >= 10)
6387 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6389 PL_in_my_stash = Nullhv;