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;
827 PL_lex_state = LEX_INTERPCONCAT;
828 PL_lex_repl = Nullsv;
833 PL_bufend = SvPVX(PL_linestr);
834 PL_bufend += SvCUR(PL_linestr);
835 PL_expect = XOPERATOR;
843 Extracts a pattern, double-quoted string, or transliteration. This
846 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
847 processing a pattern (PL_lex_inpat is true), a transliteration
848 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
850 Returns a pointer to the character scanned up to. Iff this is
851 advanced from the start pointer supplied (ie if anything was
852 successfully parsed), will leave an OP for the substring scanned
853 in yylval. Caller must intuit reason for not parsing further
854 by looking at the next characters herself.
858 double-quoted style: \r and \n
859 regexp special ones: \D \s
861 backrefs: \1 (deprecated in substitution replacements)
862 case and quoting: \U \Q \E
863 stops on @ and $, but not for $ as tail anchor
866 characters are VERY literal, except for - not at the start or end
867 of the string, which indicates a range. scan_const expands the
868 range to the full set of intermediate characters.
870 In double-quoted strings:
872 double-quoted style: \r and \n
874 backrefs: \1 (deprecated)
875 case and quoting: \U \Q \E
878 scan_const does *not* construct ops to handle interpolated strings.
879 It stops processing as soon as it finds an embedded $ or @ variable
880 and leaves it to the caller to work out what's going on.
882 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
884 $ in pattern could be $foo or could be tail anchor. Assumption:
885 it's a tail anchor if $ is the last thing in the string, or if it's
886 followed by one of ")| \n\t"
888 \1 (backreferences) are turned into $1
890 The structure of the code is
891 while (there's a character to process) {
892 handle transliteration ranges
894 skip # initiated comments in //x patterns
895 check for embedded @foo
896 check for embedded scalars
898 leave intact backslashes from leave (below)
899 deprecate \1 in strings and sub replacements
900 handle string-changing backslashes \l \U \Q \E, etc.
901 switch (what was escaped) {
902 handle - in a transliteration (becomes a literal -)
903 handle \132 octal characters
904 handle 0x15 hex characters
905 handle \cV (control V)
906 handle printf backslashes (\f, \r, \n, etc)
909 } (end while character to read)
914 scan_const(char *start)
916 register char *send = PL_bufend; /* end of the constant */
917 SV *sv = NEWSV(93, send - start); /* sv for the constant */
918 register char *s = start; /* start of the constant */
919 register char *d = SvPVX(sv); /* destination for copies */
920 bool dorange = FALSE; /* are we in a translit range? */
922 I32 utf = PL_lex_inwhat == OP_TRANS
923 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
925 I32 thisutf = PL_lex_inwhat == OP_TRANS
926 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
929 /* leaveit is the set of acceptably-backslashed characters */
932 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
935 while (s < send || dorange) {
936 /* get transliterations out of the way (they're most literal) */
937 if (PL_lex_inwhat == OP_TRANS) {
938 /* expand a range A-Z to the full set of characters. AIE! */
940 I32 i; /* current expanded character */
941 I32 min; /* first character in range */
942 I32 max; /* last character in range */
944 i = d - SvPVX(sv); /* remember current offset */
945 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
946 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
947 d -= 2; /* eat the first char and the - */
949 min = (U8)*d; /* first char in range */
950 max = (U8)d[1]; /* last char in range */
953 if ((isLOWER(min) && isLOWER(max)) ||
954 (isUPPER(min) && isUPPER(max))) {
956 for (i = min; i <= max; i++)
960 for (i = min; i <= max; i++)
967 for (i = min; i <= max; i++)
970 /* mark the range as done, and continue */
975 /* range begins (ignore - as first or last char) */
976 else if (*s == '-' && s+1 < send && s != start) {
978 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
987 /* if we get here, we're not doing a transliteration */
989 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
990 except for the last char, which will be done separately. */
991 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
993 while (s < send && *s != ')')
995 } else if (s[2] == '{'
996 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
998 char *regparse = s + (s[2] == '{' ? 3 : 4);
1001 while (count && (c = *regparse)) {
1002 if (c == '\\' && regparse[1])
1010 if (*regparse != ')') {
1011 regparse--; /* Leave one char for continuation. */
1012 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1014 while (s < regparse)
1019 /* likewise skip #-initiated comments in //x patterns */
1020 else if (*s == '#' && PL_lex_inpat &&
1021 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1022 while (s+1 < send && *s != '\n')
1026 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1027 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1030 /* check for embedded scalars. only stop if we're sure it's a
1033 else if (*s == '$') {
1034 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1036 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1037 break; /* in regexp, $ might be tail anchor */
1040 /* (now in tr/// code again) */
1042 if (*s & 0x80 && thisutf) {
1043 dTHR; /* only for ckWARN */
1044 if (ckWARN(WARN_UTF8)) {
1045 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1055 if (*s == '\\' && s+1 < send) {
1058 /* some backslashes we leave behind */
1059 if (*leaveit && *s && strchr(leaveit, *s)) {
1065 /* deprecate \1 in strings and substitution replacements */
1066 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1067 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1069 dTHR; /* only for ckWARN */
1070 if (ckWARN(WARN_SYNTAX))
1071 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1076 /* string-change backslash escapes */
1077 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1082 /* if we get here, it's either a quoted -, or a digit */
1085 /* quoted - in transliterations */
1087 if (PL_lex_inwhat == OP_TRANS) {
1095 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1097 "Unrecognized escape \\%c passed through",
1099 /* default action is to copy the quoted character */
1104 /* \132 indicates an octal constant */
1105 case '0': case '1': case '2': case '3':
1106 case '4': case '5': case '6': case '7':
1107 *d++ = scan_oct(s, 3, &len);
1111 /* \x24 indicates a hex constant */
1115 char* e = strchr(s, '}');
1118 yyerror("Missing right brace on \\x{}");
1123 if (ckWARN(WARN_UTF8))
1125 "Use of \\x{} without utf8 declaration");
1127 /* note: utf always shorter than hex */
1128 d = (char*)uv_to_utf8((U8*)d,
1129 scan_hex(s + 1, e - s - 1, &len));
1134 UV uv = (UV)scan_hex(s, 2, &len);
1135 if (utf && PL_lex_inwhat == OP_TRANS &&
1136 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1138 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1141 if (uv >= 127 && UTF) {
1143 if (ckWARN(WARN_UTF8))
1145 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1154 /* \c is a control character */
1168 /* printf-style backslashes, formfeeds, newlines, etc */
1194 } /* end if (backslash) */
1197 } /* while loop to process each character */
1199 /* terminate the string and set up the sv */
1201 SvCUR_set(sv, d - SvPVX(sv));
1204 /* shrink the sv if we allocated more than we used */
1205 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1206 SvLEN_set(sv, SvCUR(sv) + 1);
1207 Renew(SvPVX(sv), SvLEN(sv), char);
1210 /* return the substring (via yylval) only if we parsed anything */
1211 if (s > PL_bufptr) {
1212 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1213 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1215 ( PL_lex_inwhat == OP_TRANS
1217 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1220 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1226 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1228 intuit_more(register char *s)
1230 if (PL_lex_brackets)
1232 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1234 if (*s != '{' && *s != '[')
1239 /* In a pattern, so maybe we have {n,m}. */
1256 /* On the other hand, maybe we have a character class */
1259 if (*s == ']' || *s == '^')
1262 int weight = 2; /* let's weigh the evidence */
1264 unsigned char un_char = 255, last_un_char;
1265 char *send = strchr(s,']');
1266 char tmpbuf[sizeof PL_tokenbuf * 4];
1268 if (!send) /* has to be an expression */
1271 Zero(seen,256,char);
1274 else if (isDIGIT(*s)) {
1276 if (isDIGIT(s[1]) && s[2] == ']')
1282 for (; s < send; s++) {
1283 last_un_char = un_char;
1284 un_char = (unsigned char)*s;
1289 weight -= seen[un_char] * 10;
1290 if (isALNUM_lazy(s+1)) {
1291 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1292 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1297 else if (*s == '$' && s[1] &&
1298 strchr("[#!%*<>()-=",s[1])) {
1299 if (/*{*/ strchr("])} =",s[2]))
1308 if (strchr("wds]",s[1]))
1310 else if (seen['\''] || seen['"'])
1312 else if (strchr("rnftbxcav",s[1]))
1314 else if (isDIGIT(s[1])) {
1316 while (s[1] && isDIGIT(s[1]))
1326 if (strchr("aA01! ",last_un_char))
1328 if (strchr("zZ79~",s[1]))
1330 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1331 weight -= 5; /* cope with negative subscript */
1334 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1335 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1340 if (keyword(tmpbuf, d - tmpbuf))
1343 if (un_char == last_un_char + 1)
1345 weight -= seen[un_char];
1350 if (weight >= 0) /* probably a character class */
1358 intuit_method(char *start, GV *gv)
1360 char *s = start + (*start == '$');
1361 char tmpbuf[sizeof PL_tokenbuf];
1369 if ((cv = GvCVu(gv))) {
1370 char *proto = SvPVX(cv);
1380 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1381 if (*start == '$') {
1382 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1387 return *s == '(' ? FUNCMETH : METHOD;
1389 if (!keyword(tmpbuf, len)) {
1390 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1395 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1396 if (indirgv && GvCVu(indirgv))
1398 /* filehandle or package name makes it a method */
1399 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1401 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1402 return 0; /* no assumptions -- "=>" quotes bearword */
1404 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1406 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1410 return *s == '(' ? FUNCMETH : METHOD;
1420 char *pdb = PerlEnv_getenv("PERL5DB");
1424 SETERRNO(0,SS$_NORMAL);
1425 return "BEGIN { require 'perl5db.pl' }";
1431 /* Encoded script support. filter_add() effectively inserts a
1432 * 'pre-processing' function into the current source input stream.
1433 * Note that the filter function only applies to the current source file
1434 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1436 * The datasv parameter (which may be NULL) can be used to pass
1437 * private data to this instance of the filter. The filter function
1438 * can recover the SV using the FILTER_DATA macro and use it to
1439 * store private buffers and state information.
1441 * The supplied datasv parameter is upgraded to a PVIO type
1442 * and the IoDIRP field is used to store the function pointer.
1443 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1444 * private use must be set using malloc'd pointers.
1446 static int filter_debug = 0;
1449 filter_add(filter_t funcp, SV *datasv)
1451 if (!funcp){ /* temporary handy debugging hack to be deleted */
1452 filter_debug = atoi((char*)datasv);
1455 if (!PL_rsfp_filters)
1456 PL_rsfp_filters = newAV();
1458 datasv = NEWSV(255,0);
1459 if (!SvUPGRADE(datasv, SVt_PVIO))
1460 die("Can't upgrade filter_add data to SVt_PVIO");
1461 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1464 warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1466 av_unshift(PL_rsfp_filters, 1);
1467 av_store(PL_rsfp_filters, 0, datasv) ;
1472 /* Delete most recently added instance of this filter function. */
1474 filter_del(filter_t funcp)
1477 warn("filter_del func %p", funcp);
1478 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1480 /* if filter is on top of stack (usual case) just pop it off */
1481 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1482 sv_free(av_pop(PL_rsfp_filters));
1486 /* we need to search for the correct entry and clear it */
1487 die("filter_del can only delete in reverse order (currently)");
1491 /* Invoke the n'th filter function for the current rsfp. */
1493 filter_read(int idx, SV *buf_sv, int maxlen)
1496 /* 0 = read one text line */
1501 if (!PL_rsfp_filters)
1503 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1504 /* Provide a default input filter to make life easy. */
1505 /* Note that we append to the line. This is handy. */
1507 warn("filter_read %d: from rsfp\n", idx);
1511 int old_len = SvCUR(buf_sv) ;
1513 /* ensure buf_sv is large enough */
1514 SvGROW(buf_sv, old_len + maxlen) ;
1515 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1516 if (PerlIO_error(PL_rsfp))
1517 return -1; /* error */
1519 return 0 ; /* end of file */
1521 SvCUR_set(buf_sv, old_len + len) ;
1524 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1525 if (PerlIO_error(PL_rsfp))
1526 return -1; /* error */
1528 return 0 ; /* end of file */
1531 return SvCUR(buf_sv);
1533 /* Skip this filter slot if filter has been deleted */
1534 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1536 warn("filter_read %d: skipped (filter deleted)\n", idx);
1537 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1539 /* Get function pointer hidden within datasv */
1540 funcp = (filter_t)IoDIRP(datasv);
1543 warn("filter_read %d: via function %p (%s)\n",
1544 idx, funcp, SvPV(datasv,n_a));
1546 /* Call function. The function is expected to */
1547 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1548 /* Return: <0:error, =0:eof, >0:not eof */
1549 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1553 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1556 if (!PL_rsfp_filters) {
1557 filter_add(win32_textfilter,NULL);
1560 if (PL_rsfp_filters) {
1563 SvCUR_set(sv, 0); /* start with empty line */
1564 if (FILTER_READ(0, sv, 0) > 0)
1565 return ( SvPVX(sv) ) ;
1570 return (sv_gets(sv, fp, append));
1575 static char* exp_name[] =
1576 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1582 Works out what to call the token just pulled out of the input
1583 stream. The yacc parser takes care of taking the ops we return and
1584 stitching them into a tree.
1590 if read an identifier
1591 if we're in a my declaration
1592 croak if they tried to say my($foo::bar)
1593 build the ops for a my() declaration
1594 if it's an access to a my() variable
1595 are we in a sort block?
1596 croak if my($a); $a <=> $b
1597 build ops for access to a my() variable
1598 if in a dq string, and they've said @foo and we can't find @foo
1600 build ops for a bareword
1601 if we already built the token before, use it.
1604 int yylex(PERL_YYLEX_PARAM_DECL)
1614 #ifdef USE_PURE_BISON
1615 yylval_pointer = lvalp;
1616 yychar_pointer = lcharp;
1619 /* check if there's an identifier for us to look at */
1620 if (PL_pending_ident) {
1621 /* pit holds the identifier we read and pending_ident is reset */
1622 char pit = PL_pending_ident;
1623 PL_pending_ident = 0;
1625 /* if we're in a my(), we can't allow dynamics here.
1626 $foo'bar has already been turned into $foo::bar, so
1627 just check for colons.
1629 if it's a legal name, the OP is a PADANY.
1632 if (strchr(PL_tokenbuf,':'))
1633 croak(PL_no_myglob,PL_tokenbuf);
1635 yylval.opval = newOP(OP_PADANY, 0);
1636 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1641 build the ops for accesses to a my() variable.
1643 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1644 then used in a comparison. This catches most, but not
1645 all cases. For instance, it catches
1646 sort { my($a); $a <=> $b }
1648 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1649 (although why you'd do that is anyone's guess).
1652 if (!strchr(PL_tokenbuf,':')) {
1654 /* Check for single character per-thread SVs */
1655 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1656 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1657 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1659 yylval.opval = newOP(OP_THREADSV, 0);
1660 yylval.opval->op_targ = tmp;
1663 #endif /* USE_THREADS */
1664 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1665 /* if it's a sort block and they're naming $a or $b */
1666 if (PL_last_lop_op == OP_SORT &&
1667 PL_tokenbuf[0] == '$' &&
1668 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1671 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1672 d < PL_bufend && *d != '\n';
1675 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1676 croak("Can't use \"my %s\" in sort comparison",
1682 yylval.opval = newOP(OP_PADANY, 0);
1683 yylval.opval->op_targ = tmp;
1689 Whine if they've said @foo in a doublequoted string,
1690 and @foo isn't a variable we can find in the symbol
1693 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1694 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1695 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1696 yyerror(form("In string, %s now must be written as \\%s",
1697 PL_tokenbuf, PL_tokenbuf));
1700 /* build ops for a bareword */
1701 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1702 yylval.opval->op_private = OPpCONST_ENTERED;
1703 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1704 ((PL_tokenbuf[0] == '$') ? SVt_PV
1705 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1710 /* no identifier pending identification */
1712 switch (PL_lex_state) {
1714 case LEX_NORMAL: /* Some compilers will produce faster */
1715 case LEX_INTERPNORMAL: /* code if we comment these out. */
1719 /* when we're already built the next token, just pull it out the queue */
1722 yylval = PL_nextval[PL_nexttoke];
1724 PL_lex_state = PL_lex_defer;
1725 PL_expect = PL_lex_expect;
1726 PL_lex_defer = LEX_NORMAL;
1728 return(PL_nexttype[PL_nexttoke]);
1730 /* interpolated case modifiers like \L \U, including \Q and \E.
1731 when we get here, PL_bufptr is at the \
1733 case LEX_INTERPCASEMOD:
1735 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1736 croak("panic: INTERPCASEMOD");
1738 /* handle \E or end of string */
1739 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1743 if (PL_lex_casemods) {
1744 oldmod = PL_lex_casestack[--PL_lex_casemods];
1745 PL_lex_casestack[PL_lex_casemods] = '\0';
1747 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1749 PL_lex_state = LEX_INTERPCONCAT;
1753 if (PL_bufptr != PL_bufend)
1755 PL_lex_state = LEX_INTERPCONCAT;
1756 return yylex(PERL_YYLEX_PARAM);
1760 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1761 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1762 if (strchr("LU", *s) &&
1763 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1765 PL_lex_casestack[--PL_lex_casemods] = '\0';
1768 if (PL_lex_casemods > 10) {
1769 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1770 if (newlb != PL_lex_casestack) {
1772 PL_lex_casestack = newlb;
1775 PL_lex_casestack[PL_lex_casemods++] = *s;
1776 PL_lex_casestack[PL_lex_casemods] = '\0';
1777 PL_lex_state = LEX_INTERPCONCAT;
1778 PL_nextval[PL_nexttoke].ival = 0;
1781 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1783 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1785 PL_nextval[PL_nexttoke].ival = OP_LC;
1787 PL_nextval[PL_nexttoke].ival = OP_UC;
1789 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1791 croak("panic: yylex");
1794 if (PL_lex_starts) {
1800 return yylex(PERL_YYLEX_PARAM);
1803 case LEX_INTERPPUSH:
1804 return sublex_push();
1806 case LEX_INTERPSTART:
1807 if (PL_bufptr == PL_bufend)
1808 return sublex_done();
1810 PL_lex_dojoin = (*PL_bufptr == '@');
1811 PL_lex_state = LEX_INTERPNORMAL;
1812 if (PL_lex_dojoin) {
1813 PL_nextval[PL_nexttoke].ival = 0;
1816 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1817 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1818 force_next(PRIVATEREF);
1820 force_ident("\"", '$');
1821 #endif /* USE_THREADS */
1822 PL_nextval[PL_nexttoke].ival = 0;
1824 PL_nextval[PL_nexttoke].ival = 0;
1826 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1829 if (PL_lex_starts++) {
1833 return yylex(PERL_YYLEX_PARAM);
1835 case LEX_INTERPENDMAYBE:
1836 if (intuit_more(PL_bufptr)) {
1837 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1843 if (PL_lex_dojoin) {
1844 PL_lex_dojoin = FALSE;
1845 PL_lex_state = LEX_INTERPCONCAT;
1849 case LEX_INTERPCONCAT:
1851 if (PL_lex_brackets)
1852 croak("panic: INTERPCONCAT");
1854 if (PL_bufptr == PL_bufend)
1855 return sublex_done();
1857 if (SvIVX(PL_linestr) == '\'') {
1858 SV *sv = newSVsv(PL_linestr);
1861 else if ( PL_hints & HINT_NEW_RE )
1862 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1863 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1867 s = scan_const(PL_bufptr);
1869 PL_lex_state = LEX_INTERPCASEMOD;
1871 PL_lex_state = LEX_INTERPSTART;
1874 if (s != PL_bufptr) {
1875 PL_nextval[PL_nexttoke] = yylval;
1878 if (PL_lex_starts++)
1882 return yylex(PERL_YYLEX_PARAM);
1886 return yylex(PERL_YYLEX_PARAM);
1888 PL_lex_state = LEX_NORMAL;
1889 s = scan_formline(PL_bufptr);
1890 if (!PL_lex_formbrack)
1896 PL_oldoldbufptr = PL_oldbufptr;
1899 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1905 if (isIDFIRST_lazy(s))
1907 croak("Unrecognized character \\x%02X", *s & 255);
1910 goto fake_eof; /* emulate EOF on ^D or ^Z */
1915 if (PL_lex_brackets)
1916 yyerror("Missing right bracket");
1919 if (s++ < PL_bufend)
1920 goto retry; /* ignore stray nulls */
1923 if (!PL_in_eval && !PL_preambled) {
1924 PL_preambled = TRUE;
1925 sv_setpv(PL_linestr,incl_perldb());
1926 if (SvCUR(PL_linestr))
1927 sv_catpv(PL_linestr,";");
1929 while(AvFILLp(PL_preambleav) >= 0) {
1930 SV *tmpsv = av_shift(PL_preambleav);
1931 sv_catsv(PL_linestr, tmpsv);
1932 sv_catpv(PL_linestr, ";");
1935 sv_free((SV*)PL_preambleav);
1936 PL_preambleav = NULL;
1938 if (PL_minus_n || PL_minus_p) {
1939 sv_catpv(PL_linestr, "LINE: while (<>) {");
1941 sv_catpv(PL_linestr,"chomp;");
1943 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1945 GvIMPORTED_AV_on(gv);
1947 if (strchr("/'\"", *PL_splitstr)
1948 && strchr(PL_splitstr + 1, *PL_splitstr))
1949 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1952 s = "'~#\200\1'"; /* surely one char is unused...*/
1953 while (s[1] && strchr(PL_splitstr, *s)) s++;
1955 sv_catpvf(PL_linestr, "@F=split(%s%c",
1956 "q" + (delim == '\''), delim);
1957 for (s = PL_splitstr; *s; s++) {
1959 sv_catpvn(PL_linestr, "\\", 1);
1960 sv_catpvn(PL_linestr, s, 1);
1962 sv_catpvf(PL_linestr, "%c);", delim);
1966 sv_catpv(PL_linestr,"@F=split(' ');");
1969 sv_catpv(PL_linestr, "\n");
1970 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1971 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1972 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1973 SV *sv = NEWSV(85,0);
1975 sv_upgrade(sv, SVt_PVMG);
1976 sv_setsv(sv,PL_linestr);
1977 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1982 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1985 if (PL_preprocess && !PL_in_eval)
1986 (void)PerlProc_pclose(PL_rsfp);
1987 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1988 PerlIO_clearerr(PL_rsfp);
1990 (void)PerlIO_close(PL_rsfp);
1992 PL_doextract = FALSE;
1994 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1995 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1996 sv_catpv(PL_linestr,";}");
1997 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1998 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1999 PL_minus_n = PL_minus_p = 0;
2002 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2003 sv_setpv(PL_linestr,"");
2004 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2007 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2008 PL_doextract = FALSE;
2010 /* Incest with pod. */
2011 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2012 sv_setpv(PL_linestr, "");
2013 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2014 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2015 PL_doextract = FALSE;
2019 } while (PL_doextract);
2020 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2021 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2022 SV *sv = NEWSV(85,0);
2024 sv_upgrade(sv, SVt_PVMG);
2025 sv_setsv(sv,PL_linestr);
2026 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2028 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2029 if (PL_curcop->cop_line == 1) {
2030 while (s < PL_bufend && isSPACE(*s))
2032 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2036 if (*s == '#' && *(s+1) == '!')
2038 #ifdef ALTERNATE_SHEBANG
2040 static char as[] = ALTERNATE_SHEBANG;
2041 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2042 d = s + (sizeof(as) - 1);
2044 #endif /* ALTERNATE_SHEBANG */
2053 while (*d && !isSPACE(*d))
2057 #ifdef ARG_ZERO_IS_SCRIPT
2058 if (ipathend > ipath) {
2060 * HP-UX (at least) sets argv[0] to the script name,
2061 * which makes $^X incorrect. And Digital UNIX and Linux,
2062 * at least, set argv[0] to the basename of the Perl
2063 * interpreter. So, having found "#!", we'll set it right.
2065 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2066 assert(SvPOK(x) || SvGMAGICAL(x));
2067 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2068 sv_setpvn(x, ipath, ipathend - ipath);
2071 TAINT_NOT; /* $^X is always tainted, but that's OK */
2073 #endif /* ARG_ZERO_IS_SCRIPT */
2078 d = instr(s,"perl -");
2080 d = instr(s,"perl");
2081 #ifdef ALTERNATE_SHEBANG
2083 * If the ALTERNATE_SHEBANG on this system starts with a
2084 * character that can be part of a Perl expression, then if
2085 * we see it but not "perl", we're probably looking at the
2086 * start of Perl code, not a request to hand off to some
2087 * other interpreter. Similarly, if "perl" is there, but
2088 * not in the first 'word' of the line, we assume the line
2089 * contains the start of the Perl program.
2091 if (d && *s != '#') {
2093 while (*c && !strchr("; \t\r\n\f\v#", *c))
2096 d = Nullch; /* "perl" not in first word; ignore */
2098 *s = '#'; /* Don't try to parse shebang line */
2100 #endif /* ALTERNATE_SHEBANG */
2105 !instr(s,"indir") &&
2106 instr(PL_origargv[0],"perl"))
2112 while (s < PL_bufend && isSPACE(*s))
2114 if (s < PL_bufend) {
2115 Newz(899,newargv,PL_origargc+3,char*);
2117 while (s < PL_bufend && !isSPACE(*s))
2120 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2123 newargv = PL_origargv;
2125 execv(ipath, newargv);
2126 croak("Can't exec %s", ipath);
2129 U32 oldpdb = PL_perldb;
2130 bool oldn = PL_minus_n;
2131 bool oldp = PL_minus_p;
2133 while (*d && !isSPACE(*d)) d++;
2134 while (*d == ' ' || *d == '\t') d++;
2138 if (*d == 'M' || *d == 'm') {
2140 while (*d && !isSPACE(*d)) d++;
2141 croak("Too late for \"-%.*s\" option",
2144 d = moreswitches(d);
2146 if (PERLDB_LINE && !oldpdb ||
2147 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2148 /* if we have already added "LINE: while (<>) {",
2149 we must not do it again */
2151 sv_setpv(PL_linestr, "");
2152 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2153 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2154 PL_preambled = FALSE;
2156 (void)gv_fetchfile(PL_origfilename);
2163 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2165 PL_lex_state = LEX_FORMLINE;
2166 return yylex(PERL_YYLEX_PARAM);
2170 #ifdef PERL_STRICT_CR
2171 warn("Illegal character \\%03o (carriage return)", '\r');
2173 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2175 case ' ': case '\t': case '\f': case 013:
2180 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2182 while (s < d && *s != '\n')
2187 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2189 PL_lex_state = LEX_FORMLINE;
2190 return yylex(PERL_YYLEX_PARAM);
2199 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2204 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2207 if (strnEQ(s,"=>",2)) {
2208 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2209 OPERATOR('-'); /* unary minus */
2211 PL_last_uni = PL_oldbufptr;
2212 PL_last_lop_op = OP_FTEREAD; /* good enough */
2214 case 'r': FTST(OP_FTEREAD);
2215 case 'w': FTST(OP_FTEWRITE);
2216 case 'x': FTST(OP_FTEEXEC);
2217 case 'o': FTST(OP_FTEOWNED);
2218 case 'R': FTST(OP_FTRREAD);
2219 case 'W': FTST(OP_FTRWRITE);
2220 case 'X': FTST(OP_FTREXEC);
2221 case 'O': FTST(OP_FTROWNED);
2222 case 'e': FTST(OP_FTIS);
2223 case 'z': FTST(OP_FTZERO);
2224 case 's': FTST(OP_FTSIZE);
2225 case 'f': FTST(OP_FTFILE);
2226 case 'd': FTST(OP_FTDIR);
2227 case 'l': FTST(OP_FTLINK);
2228 case 'p': FTST(OP_FTPIPE);
2229 case 'S': FTST(OP_FTSOCK);
2230 case 'u': FTST(OP_FTSUID);
2231 case 'g': FTST(OP_FTSGID);
2232 case 'k': FTST(OP_FTSVTX);
2233 case 'b': FTST(OP_FTBLK);
2234 case 'c': FTST(OP_FTCHR);
2235 case 't': FTST(OP_FTTTY);
2236 case 'T': FTST(OP_FTTEXT);
2237 case 'B': FTST(OP_FTBINARY);
2238 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2239 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2240 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2242 croak("Unrecognized file test: -%c", (int)tmp);
2249 if (PL_expect == XOPERATOR)
2254 else if (*s == '>') {
2257 if (isIDFIRST_lazy(s)) {
2258 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2266 if (PL_expect == XOPERATOR)
2269 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2271 OPERATOR('-'); /* unary minus */
2278 if (PL_expect == XOPERATOR)
2283 if (PL_expect == XOPERATOR)
2286 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2292 if (PL_expect != XOPERATOR) {
2293 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2294 PL_expect = XOPERATOR;
2295 force_ident(PL_tokenbuf, '*');
2308 if (PL_expect == XOPERATOR) {
2312 PL_tokenbuf[0] = '%';
2313 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2314 if (!PL_tokenbuf[1]) {
2316 yyerror("Final % should be \\% or %name");
2319 PL_pending_ident = '%';
2341 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2342 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2347 if (PL_curcop->cop_line < PL_copline)
2348 PL_copline = PL_curcop->cop_line;
2359 if (PL_lex_brackets <= 0)
2360 yyerror("Unmatched right bracket");
2363 if (PL_lex_state == LEX_INTERPNORMAL) {
2364 if (PL_lex_brackets == 0) {
2365 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2366 PL_lex_state = LEX_INTERPEND;
2373 if (PL_lex_brackets > 100) {
2374 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2375 if (newlb != PL_lex_brackstack) {
2377 PL_lex_brackstack = newlb;
2380 switch (PL_expect) {
2382 if (PL_lex_formbrack) {
2386 if (PL_oldoldbufptr == PL_last_lop)
2387 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2389 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2390 OPERATOR(HASHBRACK);
2392 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2395 PL_tokenbuf[0] = '\0';
2396 if (d < PL_bufend && *d == '-') {
2397 PL_tokenbuf[0] = '-';
2399 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2402 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2403 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2405 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2408 char minus = (PL_tokenbuf[0] == '-');
2409 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2416 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2420 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2425 if (PL_oldoldbufptr == PL_last_lop)
2426 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2428 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2431 OPERATOR(HASHBRACK);
2432 /* This hack serves to disambiguate a pair of curlies
2433 * as being a block or an anon hash. Normally, expectation
2434 * determines that, but in cases where we're not in a
2435 * position to expect anything in particular (like inside
2436 * eval"") we have to resolve the ambiguity. This code
2437 * covers the case where the first term in the curlies is a
2438 * quoted string. Most other cases need to be explicitly
2439 * disambiguated by prepending a `+' before the opening
2440 * curly in order to force resolution as an anon hash.
2442 * XXX should probably propagate the outer expectation
2443 * into eval"" to rely less on this hack, but that could
2444 * potentially break current behavior of eval"".
2448 if (*s == '\'' || *s == '"' || *s == '`') {
2449 /* common case: get past first string, handling escapes */
2450 for (t++; t < PL_bufend && *t != *s;)
2451 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2455 else if (*s == 'q') {
2458 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2459 && !isALNUM(*t)))) {
2461 char open, close, term;
2464 while (t < PL_bufend && isSPACE(*t))
2468 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2472 for (t++; t < PL_bufend; t++) {
2473 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2475 else if (*t == open)
2479 for (t++; t < PL_bufend; t++) {
2480 if (*t == '\\' && t+1 < PL_bufend)
2482 else if (*t == close && --brackets <= 0)
2484 else if (*t == open)
2490 else if (isIDFIRST_lazy(s)) {
2491 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2493 while (t < PL_bufend && isSPACE(*t))
2495 /* if comma follows first term, call it an anon hash */
2496 /* XXX it could be a comma expression with loop modifiers */
2497 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2498 || (*t == '=' && t[1] == '>')))
2499 OPERATOR(HASHBRACK);
2500 if (PL_expect == XREF)
2501 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2503 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2509 yylval.ival = PL_curcop->cop_line;
2510 if (isSPACE(*s) || *s == '#')
2511 PL_copline = NOLINE; /* invalidate current command line number */
2516 if (PL_lex_brackets <= 0)
2517 yyerror("Unmatched right bracket");
2519 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2520 if (PL_lex_brackets < PL_lex_formbrack)
2521 PL_lex_formbrack = 0;
2522 if (PL_lex_state == LEX_INTERPNORMAL) {
2523 if (PL_lex_brackets == 0) {
2524 if (PL_lex_fakebrack) {
2525 PL_lex_state = LEX_INTERPEND;
2527 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2529 if (*s == '-' && s[1] == '>')
2530 PL_lex_state = LEX_INTERPENDMAYBE;
2531 else if (*s != '[' && *s != '{')
2532 PL_lex_state = LEX_INTERPEND;
2535 if (PL_lex_brackets < PL_lex_fakebrack) {
2537 PL_lex_fakebrack = 0;
2538 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2548 if (PL_expect == XOPERATOR) {
2549 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2550 PL_curcop->cop_line--;
2551 warner(WARN_SEMICOLON, PL_warn_nosemi);
2552 PL_curcop->cop_line++;
2557 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2559 PL_expect = XOPERATOR;
2560 force_ident(PL_tokenbuf, '&');
2564 yylval.ival = (OPpENTERSUB_AMPER<<8);
2583 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2584 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2586 if (PL_expect == XSTATE && isALPHA(tmp) &&
2587 (s == PL_linestart+1 || s[-2] == '\n') )
2589 if (PL_in_eval && !PL_rsfp) {
2594 if (strnEQ(s,"=cut",4)) {
2608 PL_doextract = TRUE;
2611 if (PL_lex_brackets < PL_lex_formbrack) {
2613 #ifdef PERL_STRICT_CR
2614 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2616 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2618 if (*t == '\n' || *t == '#') {
2636 if (PL_expect != XOPERATOR) {
2637 if (s[1] != '<' && !strchr(s,'>'))
2640 s = scan_heredoc(s);
2642 s = scan_inputsymbol(s);
2643 TERM(sublex_start());
2648 SHop(OP_LEFT_SHIFT);
2662 SHop(OP_RIGHT_SHIFT);
2671 if (PL_expect == XOPERATOR) {
2672 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2675 return ','; /* grandfather non-comma-format format */
2679 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2680 if (PL_expect == XOPERATOR)
2681 no_op("Array length", PL_bufptr);
2682 PL_tokenbuf[0] = '@';
2683 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2685 if (!PL_tokenbuf[1])
2687 PL_expect = XOPERATOR;
2688 PL_pending_ident = '#';
2692 if (PL_expect == XOPERATOR)
2693 no_op("Scalar", PL_bufptr);
2694 PL_tokenbuf[0] = '$';
2695 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2696 if (!PL_tokenbuf[1]) {
2698 yyerror("Final $ should be \\$ or $name");
2702 /* This kludge not intended to be bulletproof. */
2703 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2704 yylval.opval = newSVOP(OP_CONST, 0,
2705 newSViv((IV)PL_compiling.cop_arybase));
2706 yylval.opval->op_private = OPpCONST_ARYBASE;
2711 if (PL_lex_state == LEX_NORMAL)
2714 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2717 PL_tokenbuf[0] = '@';
2718 if (ckWARN(WARN_SYNTAX)) {
2720 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2723 PL_bufptr = skipspace(PL_bufptr);
2724 while (t < PL_bufend && *t != ']')
2727 "Multidimensional syntax %.*s not supported",
2728 (t - PL_bufptr) + 1, PL_bufptr);
2732 else if (*s == '{') {
2733 PL_tokenbuf[0] = '%';
2734 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2735 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2737 char tmpbuf[sizeof PL_tokenbuf];
2739 for (t++; isSPACE(*t); t++) ;
2740 if (isIDFIRST_lazy(t)) {
2741 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2742 for (; isSPACE(*t); t++) ;
2743 if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
2745 "You need to quote \"%s\"", tmpbuf);
2751 PL_expect = XOPERATOR;
2752 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2753 bool islop = (PL_last_lop == PL_oldoldbufptr);
2754 if (!islop || PL_last_lop_op == OP_GREPSTART)
2755 PL_expect = XOPERATOR;
2756 else if (strchr("$@\"'`q", *s))
2757 PL_expect = XTERM; /* e.g. print $fh "foo" */
2758 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2759 PL_expect = XTERM; /* e.g. print $fh &sub */
2760 else if (isIDFIRST_lazy(s)) {
2761 char tmpbuf[sizeof PL_tokenbuf];
2762 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2763 if (tmp = keyword(tmpbuf, len)) {
2764 /* binary operators exclude handle interpretations */
2776 PL_expect = XTERM; /* e.g. print $fh length() */
2781 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2782 if (gv && GvCVu(gv))
2783 PL_expect = XTERM; /* e.g. print $fh subr() */
2786 else if (isDIGIT(*s))
2787 PL_expect = XTERM; /* e.g. print $fh 3 */
2788 else if (*s == '.' && isDIGIT(s[1]))
2789 PL_expect = XTERM; /* e.g. print $fh .3 */
2790 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2791 PL_expect = XTERM; /* e.g. print $fh -1 */
2792 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2793 PL_expect = XTERM; /* print $fh <<"EOF" */
2795 PL_pending_ident = '$';
2799 if (PL_expect == XOPERATOR)
2801 PL_tokenbuf[0] = '@';
2802 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2803 if (!PL_tokenbuf[1]) {
2805 yyerror("Final @ should be \\@ or @name");
2808 if (PL_lex_state == LEX_NORMAL)
2810 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2812 PL_tokenbuf[0] = '%';
2814 /* Warn about @ where they meant $. */
2815 if (ckWARN(WARN_SYNTAX)) {
2816 if (*s == '[' || *s == '{') {
2818 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2820 if (*t == '}' || *t == ']') {
2822 PL_bufptr = skipspace(PL_bufptr);
2824 "Scalar value %.*s better written as $%.*s",
2825 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2830 PL_pending_ident = '@';
2833 case '/': /* may either be division or pattern */
2834 case '?': /* may either be conditional or pattern */
2835 if (PL_expect != XOPERATOR) {
2836 /* Disable warning on "study /blah/" */
2837 if (PL_oldoldbufptr == PL_last_uni
2838 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2839 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2841 s = scan_pat(s,OP_MATCH);
2842 TERM(sublex_start());
2850 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2851 #ifdef PERL_STRICT_CR
2854 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2856 && (s == PL_linestart || s[-1] == '\n') )
2858 PL_lex_formbrack = 0;
2862 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2868 yylval.ival = OPf_SPECIAL;
2874 if (PL_expect != XOPERATOR)
2879 case '0': case '1': case '2': case '3': case '4':
2880 case '5': case '6': case '7': case '8': case '9':
2882 if (PL_expect == XOPERATOR)
2888 if (PL_expect == XOPERATOR) {
2889 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2892 return ','; /* grandfather non-comma-format format */
2898 missingterm((char*)0);
2899 yylval.ival = OP_CONST;
2900 TERM(sublex_start());
2904 if (PL_expect == XOPERATOR) {
2905 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2908 return ','; /* grandfather non-comma-format format */
2914 missingterm((char*)0);
2915 yylval.ival = OP_CONST;
2916 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2917 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2918 yylval.ival = OP_STRINGIFY;
2922 TERM(sublex_start());
2926 if (PL_expect == XOPERATOR)
2927 no_op("Backticks",s);
2929 missingterm((char*)0);
2930 yylval.ival = OP_BACKTICK;
2932 TERM(sublex_start());
2936 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2937 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2939 if (PL_expect == XOPERATOR)
2940 no_op("Backslash",s);
2944 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2984 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2986 /* Some keywords can be followed by any delimiter, including ':' */
2987 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2988 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2989 (PL_tokenbuf[0] == 'q' &&
2990 strchr("qwxr", PL_tokenbuf[1]))));
2992 /* x::* is just a word, unless x is "CORE" */
2993 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2997 while (d < PL_bufend && isSPACE(*d))
2998 d++; /* no comments skipped here, or s### is misparsed */
3000 /* Is this a label? */
3001 if (!tmp && PL_expect == XSTATE
3002 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3004 yylval.pval = savepv(PL_tokenbuf);
3009 /* Check for keywords */
3010 tmp = keyword(PL_tokenbuf, len);
3012 /* Is this a word before a => operator? */
3013 if (strnEQ(d,"=>",2)) {
3015 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3016 yylval.opval->op_private = OPpCONST_BARE;
3020 if (tmp < 0) { /* second-class keyword? */
3021 GV *ogv = Nullgv; /* override (winner) */
3022 GV *hgv = Nullgv; /* hidden (loser) */
3023 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3025 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3028 if (GvIMPORTED_CV(gv))
3030 else if (! CvMETHOD(cv))
3034 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3035 (gv = *gvp) != (GV*)&PL_sv_undef &&
3036 GvCVu(gv) && GvIMPORTED_CV(gv))
3042 tmp = 0; /* overridden by import or by GLOBAL */
3045 && -tmp==KEY_lock /* XXX generalizable kludge */
3046 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3048 tmp = 0; /* any sub overrides "weak" keyword */
3050 else { /* no override */
3054 if (ckWARN(WARN_AMBIGUOUS) && hgv
3055 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3056 warner(WARN_AMBIGUOUS,
3057 "Ambiguous call resolved as CORE::%s(), %s",
3058 GvENAME(hgv), "qualify as such or use &");
3065 default: /* not a keyword */
3068 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3070 /* Get the rest if it looks like a package qualifier */
3072 if (*s == '\'' || *s == ':' && s[1] == ':') {
3074 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3077 croak("Bad name after %s%s", PL_tokenbuf,
3078 *s == '\'' ? "'" : "::");
3082 if (PL_expect == XOPERATOR) {
3083 if (PL_bufptr == PL_linestart) {
3084 PL_curcop->cop_line--;
3085 warner(WARN_SEMICOLON, PL_warn_nosemi);
3086 PL_curcop->cop_line++;
3089 no_op("Bareword",s);
3092 /* Look for a subroutine with this name in current package,
3093 unless name is "Foo::", in which case Foo is a bearword
3094 (and a package name). */
3097 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3099 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3101 "Bareword \"%s\" refers to nonexistent package",
3104 PL_tokenbuf[len] = '\0';
3111 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3114 /* if we saw a global override before, get the right name */
3117 sv = newSVpv("CORE::GLOBAL::",14);
3118 sv_catpv(sv,PL_tokenbuf);
3121 sv = newSVpv(PL_tokenbuf,0);
3123 /* Presume this is going to be a bareword of some sort. */
3126 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3127 yylval.opval->op_private = OPpCONST_BARE;
3129 /* And if "Foo::", then that's what it certainly is. */
3134 /* See if it's the indirect object for a list operator. */
3136 if (PL_oldoldbufptr &&
3137 PL_oldoldbufptr < PL_bufptr &&
3138 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3139 /* NO SKIPSPACE BEFORE HERE! */
3141 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3142 || (PL_last_lop_op == OP_ENTERSUB
3144 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3146 bool immediate_paren = *s == '(';
3148 /* (Now we can afford to cross potential line boundary.) */
3151 /* Two barewords in a row may indicate method call. */
3153 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3156 /* If not a declared subroutine, it's an indirect object. */
3157 /* (But it's an indir obj regardless for sort.) */
3159 if ((PL_last_lop_op == OP_SORT ||
3160 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3161 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3162 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3167 /* If followed by a paren, it's certainly a subroutine. */
3169 PL_expect = XOPERATOR;
3173 if (gv && GvCVu(gv)) {
3175 if ((cv = GvCV(gv)) && SvPOK(cv))
3176 PL_last_proto = SvPV((SV*)cv, n_a);
3177 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3178 if (*d == ')' && (sv = cv_const_sv(cv))) {
3183 PL_nextval[PL_nexttoke].opval = yylval.opval;
3184 PL_expect = XOPERATOR;
3187 PL_last_lop_op = OP_ENTERSUB;
3191 /* If followed by var or block, call it a method (unless sub) */
3193 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3194 PL_last_lop = PL_oldbufptr;
3195 PL_last_lop_op = OP_METHOD;
3199 /* If followed by a bareword, see if it looks like indir obj. */
3201 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3204 /* Not a method, so call it a subroutine (if defined) */
3206 if (gv && GvCVu(gv)) {
3208 if (lastchar == '-')
3209 warn("Ambiguous use of -%s resolved as -&%s()",
3210 PL_tokenbuf, PL_tokenbuf);
3211 PL_last_lop = PL_oldbufptr;
3212 PL_last_lop_op = OP_ENTERSUB;
3213 /* Check for a constant sub */
3215 if ((sv = cv_const_sv(cv))) {
3217 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3218 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3219 yylval.opval->op_private = 0;
3223 /* Resolve to GV now. */
3224 op_free(yylval.opval);
3225 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3226 PL_last_lop_op = OP_ENTERSUB;
3227 /* Is there a prototype? */
3230 PL_last_proto = SvPV((SV*)cv, len);
3233 if (strEQ(PL_last_proto, "$"))
3235 if (*PL_last_proto == '&' && *s == '{') {
3236 sv_setpv(PL_subname,"__ANON__");
3240 PL_last_proto = NULL;
3241 PL_nextval[PL_nexttoke].opval = yylval.opval;
3247 if (PL_hints & HINT_STRICT_SUBS &&
3250 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3251 PL_last_lop_op != OP_ACCEPT &&
3252 PL_last_lop_op != OP_PIPE_OP &&
3253 PL_last_lop_op != OP_SOCKPAIR &&
3254 !(PL_last_lop_op == OP_ENTERSUB
3256 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3259 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3264 /* Call it a bare word */
3267 if (ckWARN(WARN_RESERVED)) {
3268 if (lastchar != '-') {
3269 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3271 warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
3276 if (lastchar && strchr("*%&", lastchar)) {
3277 warn("Operator or semicolon missing before %c%s",
3278 lastchar, PL_tokenbuf);
3279 warn("Ambiguous use of %c resolved as operator %c",
3280 lastchar, lastchar);
3286 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3287 newSVsv(GvSV(PL_curcop->cop_filegv)));
3291 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3292 newSVpvf("%ld", (long)PL_curcop->cop_line));
3295 case KEY___PACKAGE__:
3296 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3298 ? newSVsv(PL_curstname)
3307 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3308 char *pname = "main";
3309 if (PL_tokenbuf[2] == 'D')
3310 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3311 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3314 GvIOp(gv) = newIO();
3315 IoIFP(GvIOp(gv)) = PL_rsfp;
3316 #if defined(HAS_FCNTL) && defined(F_SETFD)
3318 int fd = PerlIO_fileno(PL_rsfp);
3319 fcntl(fd,F_SETFD,fd >= 3);
3322 /* Mark this internal pseudo-handle as clean */
3323 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3325 IoTYPE(GvIOp(gv)) = '|';
3326 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3327 IoTYPE(GvIOp(gv)) = '-';
3329 IoTYPE(GvIOp(gv)) = '<';
3340 if (PL_expect == XSTATE) {
3347 if (*s == ':' && s[1] == ':') {
3350 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3351 tmp = keyword(PL_tokenbuf, len);
3365 LOP(OP_ACCEPT,XTERM);
3371 LOP(OP_ATAN2,XTERM);
3380 LOP(OP_BLESS,XTERM);
3389 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3406 if (!PL_cryptseen++)
3409 LOP(OP_CRYPT,XTERM);
3412 if (ckWARN(WARN_OCTAL)) {
3413 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3414 if (*d != '0' && isDIGIT(*d))
3415 yywarn("chmod: mode argument is missing initial 0");
3417 LOP(OP_CHMOD,XTERM);
3420 LOP(OP_CHOWN,XTERM);
3423 LOP(OP_CONNECT,XTERM);
3439 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3443 PL_hints |= HINT_BLOCK_SCOPE;
3453 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3454 LOP(OP_DBMOPEN,XTERM);
3460 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3467 yylval.ival = PL_curcop->cop_line;
3481 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3482 UNIBRACK(OP_ENTEREVAL);
3497 case KEY_endhostent:
3503 case KEY_endservent:
3506 case KEY_endprotoent:
3517 yylval.ival = PL_curcop->cop_line;
3519 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3521 if ((PL_bufend - p) >= 3 &&
3522 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3525 if (isIDFIRST_lazy(p))
3526 croak("Missing $ on loop variable");
3531 LOP(OP_FORMLINE,XTERM);
3537 LOP(OP_FCNTL,XTERM);
3543 LOP(OP_FLOCK,XTERM);
3552 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3555 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3570 case KEY_getpriority:
3571 LOP(OP_GETPRIORITY,XTERM);
3573 case KEY_getprotobyname:
3576 case KEY_getprotobynumber:
3577 LOP(OP_GPBYNUMBER,XTERM);
3579 case KEY_getprotoent:
3591 case KEY_getpeername:
3592 UNI(OP_GETPEERNAME);
3594 case KEY_gethostbyname:
3597 case KEY_gethostbyaddr:
3598 LOP(OP_GHBYADDR,XTERM);
3600 case KEY_gethostent:
3603 case KEY_getnetbyname:
3606 case KEY_getnetbyaddr:
3607 LOP(OP_GNBYADDR,XTERM);
3612 case KEY_getservbyname:
3613 LOP(OP_GSBYNAME,XTERM);
3615 case KEY_getservbyport:
3616 LOP(OP_GSBYPORT,XTERM);
3618 case KEY_getservent:
3621 case KEY_getsockname:
3622 UNI(OP_GETSOCKNAME);
3624 case KEY_getsockopt:
3625 LOP(OP_GSOCKOPT,XTERM);
3647 yylval.ival = PL_curcop->cop_line;
3651 LOP(OP_INDEX,XTERM);
3657 LOP(OP_IOCTL,XTERM);
3669 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3700 LOP(OP_LISTEN,XTERM);
3709 s = scan_pat(s,OP_MATCH);
3710 TERM(sublex_start());
3713 LOP(OP_MAPSTART, XREF);
3716 LOP(OP_MKDIR,XTERM);
3719 LOP(OP_MSGCTL,XTERM);
3722 LOP(OP_MSGGET,XTERM);
3725 LOP(OP_MSGRCV,XTERM);
3728 LOP(OP_MSGSND,XTERM);
3733 if (isIDFIRST_lazy(s)) {
3734 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3735 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3736 if (!PL_in_my_stash) {
3739 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3746 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3753 if (PL_expect != XSTATE)
3754 yyerror("\"no\" not allowed in expression");
3755 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3756 s = force_version(s);
3765 if (isIDFIRST_lazy(s)) {
3767 for (d = s; isALNUM_lazy(d); d++) ;
3769 if (strchr("|&*+-=!?:.", *t))
3770 warn("Precedence problem: open %.*s should be open(%.*s)",
3776 yylval.ival = OP_OR;
3786 LOP(OP_OPEN_DIR,XTERM);
3789 checkcomma(s,PL_tokenbuf,"filehandle");
3793 checkcomma(s,PL_tokenbuf,"filehandle");
3812 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3816 LOP(OP_PIPE_OP,XTERM);
3821 missingterm((char*)0);
3822 yylval.ival = OP_CONST;
3823 TERM(sublex_start());
3831 missingterm((char*)0);
3832 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3833 d = SvPV_force(PL_lex_stuff, len);
3834 for (; len; --len, ++d) {
3837 "Possible attempt to separate words with commas");
3842 "Possible attempt to put comments in qw() list");
3848 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3849 PL_lex_stuff = Nullsv;
3852 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3855 yylval.ival = OP_SPLIT;
3859 PL_last_lop = PL_oldbufptr;
3860 PL_last_lop_op = OP_SPLIT;
3866 missingterm((char*)0);
3867 yylval.ival = OP_STRINGIFY;
3868 if (SvIVX(PL_lex_stuff) == '\'')
3869 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3870 TERM(sublex_start());
3873 s = scan_pat(s,OP_QR);
3874 TERM(sublex_start());
3879 missingterm((char*)0);
3880 yylval.ival = OP_BACKTICK;
3882 TERM(sublex_start());
3888 *PL_tokenbuf = '\0';
3889 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3890 if (isIDFIRST_lazy(PL_tokenbuf))
3891 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3893 yyerror("<> should be quotes");
3900 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3904 LOP(OP_RENAME,XTERM);
3913 LOP(OP_RINDEX,XTERM);
3936 LOP(OP_REVERSE,XTERM);
3947 TERM(sublex_start());
3949 TOKEN(1); /* force error */
3958 LOP(OP_SELECT,XTERM);
3964 LOP(OP_SEMCTL,XTERM);
3967 LOP(OP_SEMGET,XTERM);
3970 LOP(OP_SEMOP,XTERM);
3976 LOP(OP_SETPGRP,XTERM);
3978 case KEY_setpriority:
3979 LOP(OP_SETPRIORITY,XTERM);
3981 case KEY_sethostent:
3987 case KEY_setservent:
3990 case KEY_setprotoent:
4000 LOP(OP_SEEKDIR,XTERM);
4002 case KEY_setsockopt:
4003 LOP(OP_SSOCKOPT,XTERM);
4009 LOP(OP_SHMCTL,XTERM);
4012 LOP(OP_SHMGET,XTERM);
4015 LOP(OP_SHMREAD,XTERM);
4018 LOP(OP_SHMWRITE,XTERM);
4021 LOP(OP_SHUTDOWN,XTERM);
4030 LOP(OP_SOCKET,XTERM);
4032 case KEY_socketpair:
4033 LOP(OP_SOCKPAIR,XTERM);
4036 checkcomma(s,PL_tokenbuf,"subroutine name");
4038 if (*s == ';' || *s == ')') /* probably a close */
4039 croak("sort is now a reserved word");
4041 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4045 LOP(OP_SPLIT,XTERM);
4048 LOP(OP_SPRINTF,XTERM);
4051 LOP(OP_SPLICE,XTERM);
4067 LOP(OP_SUBSTR,XTERM);
4074 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4075 char tmpbuf[sizeof PL_tokenbuf];
4077 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4078 if (strchr(tmpbuf, ':'))
4079 sv_setpv(PL_subname, tmpbuf);
4081 sv_setsv(PL_subname,PL_curstname);
4082 sv_catpvn(PL_subname,"::",2);
4083 sv_catpvn(PL_subname,tmpbuf,len);
4085 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4089 PL_expect = XTERMBLOCK;
4090 sv_setpv(PL_subname,"?");
4093 if (tmp == KEY_format) {
4096 PL_lex_formbrack = PL_lex_brackets + 1;
4100 /* Look for a prototype */
4107 SvREFCNT_dec(PL_lex_stuff);
4108 PL_lex_stuff = Nullsv;
4109 croak("Prototype not terminated");
4112 d = SvPVX(PL_lex_stuff);
4114 for (p = d; *p; ++p) {
4119 SvCUR(PL_lex_stuff) = tmp;
4122 PL_nextval[1] = PL_nextval[0];
4123 PL_nexttype[1] = PL_nexttype[0];
4124 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4125 PL_nexttype[0] = THING;
4126 if (PL_nexttoke == 1) {
4127 PL_lex_defer = PL_lex_state;
4128 PL_lex_expect = PL_expect;
4129 PL_lex_state = LEX_KNOWNEXT;
4131 PL_lex_stuff = Nullsv;
4134 if (*SvPV(PL_subname,n_a) == '?') {
4135 sv_setpv(PL_subname,"__ANON__");
4142 LOP(OP_SYSTEM,XREF);
4145 LOP(OP_SYMLINK,XTERM);
4148 LOP(OP_SYSCALL,XTERM);
4151 LOP(OP_SYSOPEN,XTERM);
4154 LOP(OP_SYSSEEK,XTERM);
4157 LOP(OP_SYSREAD,XTERM);
4160 LOP(OP_SYSWRITE,XTERM);
4164 TERM(sublex_start());
4185 LOP(OP_TRUNCATE,XTERM);
4197 yylval.ival = PL_curcop->cop_line;
4201 yylval.ival = PL_curcop->cop_line;
4205 LOP(OP_UNLINK,XTERM);
4211 LOP(OP_UNPACK,XTERM);
4214 LOP(OP_UTIME,XTERM);
4217 if (ckWARN(WARN_OCTAL)) {
4218 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4219 if (*d != '0' && isDIGIT(*d))
4220 yywarn("umask: argument is missing initial 0");
4225 LOP(OP_UNSHIFT,XTERM);
4228 if (PL_expect != XSTATE)
4229 yyerror("\"use\" not allowed in expression");
4232 s = force_version(s);
4233 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4234 PL_nextval[PL_nexttoke].opval = Nullop;
4239 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4240 s = force_version(s);
4253 yylval.ival = PL_curcop->cop_line;
4257 PL_hints |= HINT_BLOCK_SCOPE;
4264 LOP(OP_WAITPID,XTERM);
4272 static char ctl_l[2];
4274 if (ctl_l[0] == '\0')
4275 ctl_l[0] = toCTRL('L');
4276 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4279 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4284 if (PL_expect == XOPERATOR)
4290 yylval.ival = OP_XOR;
4295 TERM(sublex_start());
4301 keyword(register char *d, I32 len)
4306 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4307 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4308 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4309 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4310 if (strEQ(d,"__END__")) return KEY___END__;
4314 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4319 if (strEQ(d,"and")) return -KEY_and;
4320 if (strEQ(d,"abs")) return -KEY_abs;
4323 if (strEQ(d,"alarm")) return -KEY_alarm;
4324 if (strEQ(d,"atan2")) return -KEY_atan2;
4327 if (strEQ(d,"accept")) return -KEY_accept;
4332 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4335 if (strEQ(d,"bless")) return -KEY_bless;
4336 if (strEQ(d,"bind")) return -KEY_bind;
4337 if (strEQ(d,"binmode")) return -KEY_binmode;
4340 if (strEQ(d,"CORE")) return -KEY_CORE;
4345 if (strEQ(d,"cmp")) return -KEY_cmp;
4346 if (strEQ(d,"chr")) return -KEY_chr;
4347 if (strEQ(d,"cos")) return -KEY_cos;
4350 if (strEQ(d,"chop")) return KEY_chop;
4353 if (strEQ(d,"close")) return -KEY_close;
4354 if (strEQ(d,"chdir")) return -KEY_chdir;
4355 if (strEQ(d,"chomp")) return KEY_chomp;
4356 if (strEQ(d,"chmod")) return -KEY_chmod;
4357 if (strEQ(d,"chown")) return -KEY_chown;
4358 if (strEQ(d,"crypt")) return -KEY_crypt;
4361 if (strEQ(d,"chroot")) return -KEY_chroot;
4362 if (strEQ(d,"caller")) return -KEY_caller;
4365 if (strEQ(d,"connect")) return -KEY_connect;
4368 if (strEQ(d,"closedir")) return -KEY_closedir;
4369 if (strEQ(d,"continue")) return -KEY_continue;
4374 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4379 if (strEQ(d,"do")) return KEY_do;
4382 if (strEQ(d,"die")) return -KEY_die;
4385 if (strEQ(d,"dump")) return -KEY_dump;
4388 if (strEQ(d,"delete")) return KEY_delete;
4391 if (strEQ(d,"defined")) return KEY_defined;
4392 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4395 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4400 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4401 if (strEQ(d,"END")) return KEY_END;
4406 if (strEQ(d,"eq")) return -KEY_eq;
4409 if (strEQ(d,"eof")) return -KEY_eof;
4410 if (strEQ(d,"exp")) return -KEY_exp;
4413 if (strEQ(d,"else")) return KEY_else;
4414 if (strEQ(d,"exit")) return -KEY_exit;
4415 if (strEQ(d,"eval")) return KEY_eval;
4416 if (strEQ(d,"exec")) return -KEY_exec;
4417 if (strEQ(d,"each")) return KEY_each;
4420 if (strEQ(d,"elsif")) return KEY_elsif;
4423 if (strEQ(d,"exists")) return KEY_exists;
4424 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4427 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4428 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4431 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4434 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4435 if (strEQ(d,"endservent")) return -KEY_endservent;
4438 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4445 if (strEQ(d,"for")) return KEY_for;
4448 if (strEQ(d,"fork")) return -KEY_fork;
4451 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4452 if (strEQ(d,"flock")) return -KEY_flock;
4455 if (strEQ(d,"format")) return KEY_format;
4456 if (strEQ(d,"fileno")) return -KEY_fileno;
4459 if (strEQ(d,"foreach")) return KEY_foreach;
4462 if (strEQ(d,"formline")) return -KEY_formline;
4468 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4469 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4473 if (strnEQ(d,"get",3)) {
4478 if (strEQ(d,"ppid")) return -KEY_getppid;
4479 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4482 if (strEQ(d,"pwent")) return -KEY_getpwent;
4483 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4484 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4487 if (strEQ(d,"peername")) return -KEY_getpeername;
4488 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4489 if (strEQ(d,"priority")) return -KEY_getpriority;
4492 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4495 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4499 else if (*d == 'h') {
4500 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4501 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4502 if (strEQ(d,"hostent")) return -KEY_gethostent;
4504 else if (*d == 'n') {
4505 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4506 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4507 if (strEQ(d,"netent")) return -KEY_getnetent;
4509 else if (*d == 's') {
4510 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4511 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4512 if (strEQ(d,"servent")) return -KEY_getservent;
4513 if (strEQ(d,"sockname")) return -KEY_getsockname;
4514 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4516 else if (*d == 'g') {
4517 if (strEQ(d,"grent")) return -KEY_getgrent;
4518 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4519 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4521 else if (*d == 'l') {
4522 if (strEQ(d,"login")) return -KEY_getlogin;
4524 else if (strEQ(d,"c")) return -KEY_getc;
4529 if (strEQ(d,"gt")) return -KEY_gt;
4530 if (strEQ(d,"ge")) return -KEY_ge;
4533 if (strEQ(d,"grep")) return KEY_grep;
4534 if (strEQ(d,"goto")) return KEY_goto;
4535 if (strEQ(d,"glob")) return KEY_glob;
4538 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4543 if (strEQ(d,"hex")) return -KEY_hex;
4546 if (strEQ(d,"INIT")) return KEY_INIT;
4551 if (strEQ(d,"if")) return KEY_if;
4554 if (strEQ(d,"int")) return -KEY_int;
4557 if (strEQ(d,"index")) return -KEY_index;
4558 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4563 if (strEQ(d,"join")) return -KEY_join;
4567 if (strEQ(d,"keys")) return KEY_keys;
4568 if (strEQ(d,"kill")) return -KEY_kill;
4573 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4574 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4580 if (strEQ(d,"lt")) return -KEY_lt;
4581 if (strEQ(d,"le")) return -KEY_le;
4582 if (strEQ(d,"lc")) return -KEY_lc;
4585 if (strEQ(d,"log")) return -KEY_log;
4588 if (strEQ(d,"last")) return KEY_last;
4589 if (strEQ(d,"link")) return -KEY_link;
4590 if (strEQ(d,"lock")) return -KEY_lock;
4593 if (strEQ(d,"local")) return KEY_local;
4594 if (strEQ(d,"lstat")) return -KEY_lstat;
4597 if (strEQ(d,"length")) return -KEY_length;
4598 if (strEQ(d,"listen")) return -KEY_listen;
4601 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4604 if (strEQ(d,"localtime")) return -KEY_localtime;
4610 case 1: return KEY_m;
4612 if (strEQ(d,"my")) return KEY_my;
4615 if (strEQ(d,"map")) return KEY_map;
4618 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4621 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4622 if (strEQ(d,"msgget")) return -KEY_msgget;
4623 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4624 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4629 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4632 if (strEQ(d,"next")) return KEY_next;
4633 if (strEQ(d,"ne")) return -KEY_ne;
4634 if (strEQ(d,"not")) return -KEY_not;
4635 if (strEQ(d,"no")) return KEY_no;
4640 if (strEQ(d,"or")) return -KEY_or;
4643 if (strEQ(d,"ord")) return -KEY_ord;
4644 if (strEQ(d,"oct")) return -KEY_oct;
4645 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4649 if (strEQ(d,"open")) return -KEY_open;
4652 if (strEQ(d,"opendir")) return -KEY_opendir;
4659 if (strEQ(d,"pop")) return KEY_pop;
4660 if (strEQ(d,"pos")) return KEY_pos;
4663 if (strEQ(d,"push")) return KEY_push;
4664 if (strEQ(d,"pack")) return -KEY_pack;
4665 if (strEQ(d,"pipe")) return -KEY_pipe;
4668 if (strEQ(d,"print")) return KEY_print;
4671 if (strEQ(d,"printf")) return KEY_printf;
4674 if (strEQ(d,"package")) return KEY_package;
4677 if (strEQ(d,"prototype")) return KEY_prototype;
4682 if (strEQ(d,"q")) return KEY_q;
4683 if (strEQ(d,"qr")) return KEY_qr;
4684 if (strEQ(d,"qq")) return KEY_qq;
4685 if (strEQ(d,"qw")) return KEY_qw;
4686 if (strEQ(d,"qx")) return KEY_qx;
4688 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4693 if (strEQ(d,"ref")) return -KEY_ref;
4696 if (strEQ(d,"read")) return -KEY_read;
4697 if (strEQ(d,"rand")) return -KEY_rand;
4698 if (strEQ(d,"recv")) return -KEY_recv;
4699 if (strEQ(d,"redo")) return KEY_redo;
4702 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4703 if (strEQ(d,"reset")) return -KEY_reset;
4706 if (strEQ(d,"return")) return KEY_return;
4707 if (strEQ(d,"rename")) return -KEY_rename;
4708 if (strEQ(d,"rindex")) return -KEY_rindex;
4711 if (strEQ(d,"require")) return -KEY_require;
4712 if (strEQ(d,"reverse")) return -KEY_reverse;
4713 if (strEQ(d,"readdir")) return -KEY_readdir;
4716 if (strEQ(d,"readlink")) return -KEY_readlink;
4717 if (strEQ(d,"readline")) return -KEY_readline;
4718 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4721 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4727 case 0: return KEY_s;
4729 if (strEQ(d,"scalar")) return KEY_scalar;
4734 if (strEQ(d,"seek")) return -KEY_seek;
4735 if (strEQ(d,"send")) return -KEY_send;
4738 if (strEQ(d,"semop")) return -KEY_semop;
4741 if (strEQ(d,"select")) return -KEY_select;
4742 if (strEQ(d,"semctl")) return -KEY_semctl;
4743 if (strEQ(d,"semget")) return -KEY_semget;
4746 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4747 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4750 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4751 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4754 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4757 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4758 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4759 if (strEQ(d,"setservent")) return -KEY_setservent;
4762 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4763 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4770 if (strEQ(d,"shift")) return KEY_shift;
4773 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4774 if (strEQ(d,"shmget")) return -KEY_shmget;
4777 if (strEQ(d,"shmread")) return -KEY_shmread;
4780 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4781 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4786 if (strEQ(d,"sin")) return -KEY_sin;
4789 if (strEQ(d,"sleep")) return -KEY_sleep;
4792 if (strEQ(d,"sort")) return KEY_sort;
4793 if (strEQ(d,"socket")) return -KEY_socket;
4794 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4797 if (strEQ(d,"split")) return KEY_split;
4798 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4799 if (strEQ(d,"splice")) return KEY_splice;
4802 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4805 if (strEQ(d,"srand")) return -KEY_srand;
4808 if (strEQ(d,"stat")) return -KEY_stat;
4809 if (strEQ(d,"study")) return KEY_study;
4812 if (strEQ(d,"substr")) return -KEY_substr;
4813 if (strEQ(d,"sub")) return KEY_sub;
4818 if (strEQ(d,"system")) return -KEY_system;
4821 if (strEQ(d,"symlink")) return -KEY_symlink;
4822 if (strEQ(d,"syscall")) return -KEY_syscall;
4823 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4824 if (strEQ(d,"sysread")) return -KEY_sysread;
4825 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4828 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4837 if (strEQ(d,"tr")) return KEY_tr;
4840 if (strEQ(d,"tie")) return KEY_tie;
4843 if (strEQ(d,"tell")) return -KEY_tell;
4844 if (strEQ(d,"tied")) return KEY_tied;
4845 if (strEQ(d,"time")) return -KEY_time;
4848 if (strEQ(d,"times")) return -KEY_times;
4851 if (strEQ(d,"telldir")) return -KEY_telldir;
4854 if (strEQ(d,"truncate")) return -KEY_truncate;
4861 if (strEQ(d,"uc")) return -KEY_uc;
4864 if (strEQ(d,"use")) return KEY_use;
4867 if (strEQ(d,"undef")) return KEY_undef;
4868 if (strEQ(d,"until")) return KEY_until;
4869 if (strEQ(d,"untie")) return KEY_untie;
4870 if (strEQ(d,"utime")) return -KEY_utime;
4871 if (strEQ(d,"umask")) return -KEY_umask;
4874 if (strEQ(d,"unless")) return KEY_unless;
4875 if (strEQ(d,"unpack")) return -KEY_unpack;
4876 if (strEQ(d,"unlink")) return -KEY_unlink;
4879 if (strEQ(d,"unshift")) return KEY_unshift;
4880 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4885 if (strEQ(d,"values")) return -KEY_values;
4886 if (strEQ(d,"vec")) return -KEY_vec;
4891 if (strEQ(d,"warn")) return -KEY_warn;
4892 if (strEQ(d,"wait")) return -KEY_wait;
4895 if (strEQ(d,"while")) return KEY_while;
4896 if (strEQ(d,"write")) return -KEY_write;
4899 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4902 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4907 if (len == 1) return -KEY_x;
4908 if (strEQ(d,"xor")) return -KEY_xor;
4911 if (len == 1) return KEY_y;
4920 checkcomma(register char *s, char *name, char *what)
4924 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4925 dTHR; /* only for ckWARN */
4926 if (ckWARN(WARN_SYNTAX)) {
4928 for (w = s+2; *w && level; w++) {
4935 for (; *w && isSPACE(*w); w++) ;
4936 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4937 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4940 while (s < PL_bufend && isSPACE(*s))
4944 while (s < PL_bufend && isSPACE(*s))
4946 if (isIDFIRST_lazy(s)) {
4948 while (isALNUM_lazy(s))
4950 while (s < PL_bufend && isSPACE(*s))
4955 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4959 croak("No comma allowed after %s", what);
4965 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4968 HV *table = GvHV(PL_hintgv); /* ^H */
4971 bool oldcatch = CATCH_GET;
4976 yyerror("%^H is not defined");
4979 cvp = hv_fetch(table, key, strlen(key), FALSE);
4980 if (!cvp || !SvOK(*cvp)) {
4982 sprintf(buf,"$^H{%s} is not defined", key);
4986 sv_2mortal(sv); /* Parent created it permanently */
4989 pv = sv_2mortal(newSVpv(s, len));
4991 typesv = sv_2mortal(newSVpv(type, 0));
4993 typesv = &PL_sv_undef;
4995 Zero(&myop, 1, BINOP);
4996 myop.op_last = (OP *) &myop;
4997 myop.op_next = Nullop;
4998 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
5000 PUSHSTACKi(PERLSI_OVERLOAD);
5003 PL_op = (OP *) &myop;
5004 if (PERLDB_SUB && PL_curstash != PL_debstash)
5005 PL_op->op_private |= OPpENTERSUB_DB;
5016 if (PL_op = pp_entersub(ARGS))
5023 CATCH_SET(oldcatch);
5028 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5031 return SvREFCNT_inc(res);
5035 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5037 register char *d = dest;
5038 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5041 croak(ident_too_long);
5042 if (isALNUM(*s)) /* UTF handled below */
5044 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5049 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5053 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5054 char *t = s + UTF8SKIP(s);
5055 while (*t & 0x80 && is_utf8_mark((U8*)t))
5057 if (d + (t - s) > e)
5058 croak(ident_too_long);
5059 Copy(s, d, t - s, char);
5072 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5079 if (PL_lex_brackets == 0)
5080 PL_lex_fakebrack = 0;
5084 e = d + destlen - 3; /* two-character token, ending NUL */
5086 while (isDIGIT(*s)) {
5088 croak(ident_too_long);
5095 croak(ident_too_long);
5096 if (isALNUM(*s)) /* UTF handled below */
5098 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5103 else if (*s == ':' && s[1] == ':') {
5107 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5108 char *t = s + UTF8SKIP(s);
5109 while (*t & 0x80 && is_utf8_mark((U8*)t))
5111 if (d + (t - s) > e)
5112 croak(ident_too_long);
5113 Copy(s, d, t - s, char);
5124 if (PL_lex_state != LEX_NORMAL)
5125 PL_lex_state = LEX_INTERPENDMAYBE;
5128 if (*s == '$' && s[1] &&
5129 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5142 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5147 if (isSPACE(s[-1])) {
5150 if (ch != ' ' && ch != '\t') {
5156 if (isIDFIRST_lazy(d)) {
5160 while (e < send && isALNUM_lazy(e) || *e == ':') {
5162 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5165 Copy(s, d, e - s, char);
5170 while (isALNUM(*s) || *s == ':')
5174 while (s < send && (*s == ' ' || *s == '\t')) s++;
5175 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5176 dTHR; /* only for ckWARN */
5177 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5178 char *brack = *s == '[' ? "[...]" : "{...}";
5179 warner(WARN_AMBIGUOUS,
5180 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5181 funny, dest, brack, funny, dest, brack);
5183 PL_lex_fakebrack = PL_lex_brackets+1;
5185 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5191 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5192 PL_lex_state = LEX_INTERPEND;
5195 if (PL_lex_state == LEX_NORMAL) {
5196 dTHR; /* only for ckWARN */
5197 if (ckWARN(WARN_AMBIGUOUS) &&
5198 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5200 warner(WARN_AMBIGUOUS,
5201 "Ambiguous use of %c{%s} resolved to %c%s",
5202 funny, dest, funny, dest);
5207 s = bracket; /* let the parser handle it */
5211 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5212 PL_lex_state = LEX_INTERPEND;
5216 void pmflag(U16 *pmfl, int ch)
5221 *pmfl |= PMf_GLOBAL;
5223 *pmfl |= PMf_CONTINUE;
5227 *pmfl |= PMf_MULTILINE;
5229 *pmfl |= PMf_SINGLELINE;
5231 *pmfl |= PMf_EXTENDED;
5235 scan_pat(char *start, I32 type)
5240 s = scan_str(start);
5243 SvREFCNT_dec(PL_lex_stuff);
5244 PL_lex_stuff = Nullsv;
5245 croak("Search pattern not terminated");
5248 pm = (PMOP*)newPMOP(type, 0);
5249 if (PL_multi_open == '?')
5250 pm->op_pmflags |= PMf_ONCE;
5252 while (*s && strchr("iomsx", *s))
5253 pmflag(&pm->op_pmflags,*s++);
5256 while (*s && strchr("iogcmsx", *s))
5257 pmflag(&pm->op_pmflags,*s++);
5259 pm->op_pmpermflags = pm->op_pmflags;
5261 PL_lex_op = (OP*)pm;
5262 yylval.ival = OP_MATCH;
5267 scan_subst(char *start)
5274 yylval.ival = OP_NULL;
5276 s = scan_str(start);
5280 SvREFCNT_dec(PL_lex_stuff);
5281 PL_lex_stuff = Nullsv;
5282 croak("Substitution pattern not terminated");
5285 if (s[-1] == PL_multi_open)
5288 first_start = PL_multi_start;
5292 SvREFCNT_dec(PL_lex_stuff);
5293 PL_lex_stuff = Nullsv;
5295 SvREFCNT_dec(PL_lex_repl);
5296 PL_lex_repl = Nullsv;
5297 croak("Substitution replacement not terminated");
5299 PL_multi_start = first_start; /* so whole substitution is taken together */
5301 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5307 else if (strchr("iogcmsx", *s))
5308 pmflag(&pm->op_pmflags,*s++);
5315 pm->op_pmflags |= PMf_EVAL;
5316 repl = newSVpv("",0);
5318 sv_catpv(repl, es ? "eval " : "do ");
5319 sv_catpvn(repl, "{ ", 2);
5320 sv_catsv(repl, PL_lex_repl);
5321 sv_catpvn(repl, " };", 2);
5322 SvCOMPILED_on(repl);
5323 SvREFCNT_dec(PL_lex_repl);
5327 pm->op_pmpermflags = pm->op_pmflags;
5328 PL_lex_op = (OP*)pm;
5329 yylval.ival = OP_SUBST;
5334 scan_trans(char *start)
5345 yylval.ival = OP_NULL;
5347 s = scan_str(start);
5350 SvREFCNT_dec(PL_lex_stuff);
5351 PL_lex_stuff = Nullsv;
5352 croak("Transliteration pattern not terminated");
5354 if (s[-1] == PL_multi_open)
5360 SvREFCNT_dec(PL_lex_stuff);
5361 PL_lex_stuff = Nullsv;
5363 SvREFCNT_dec(PL_lex_repl);
5364 PL_lex_repl = Nullsv;
5365 croak("Transliteration replacement not terminated");
5369 o = newSVOP(OP_TRANS, 0, 0);
5370 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5373 New(803,tbl,256,short);
5374 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5378 complement = del = squash = 0;
5379 while (strchr("cdsCU", *s)) {
5381 complement = OPpTRANS_COMPLEMENT;
5383 del = OPpTRANS_DELETE;
5385 squash = OPpTRANS_SQUASH;
5390 utf8 &= ~OPpTRANS_FROM_UTF;
5392 utf8 |= OPpTRANS_FROM_UTF;
5396 utf8 &= ~OPpTRANS_TO_UTF;
5398 utf8 |= OPpTRANS_TO_UTF;
5401 croak("Too many /C and /U options");
5406 o->op_private = del|squash|complement|utf8;
5409 yylval.ival = OP_TRANS;
5414 scan_heredoc(register char *s)
5418 I32 op_type = OP_SCALAR;
5425 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5429 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5432 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5433 if (*peek && strchr("`'\"",*peek)) {
5436 s = delimcpy(d, e, s, PL_bufend, term, &len);
5446 if (!isALNUM_lazy(s))
5447 deprecate("bare << to mean <<\"\"");
5448 for (; isALNUM_lazy(s); s++) {
5453 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5454 croak("Delimiter for here document is too long");
5457 len = d - PL_tokenbuf;
5458 #ifndef PERL_STRICT_CR
5459 d = strchr(s, '\r');
5463 while (s < PL_bufend) {
5469 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5478 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5483 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5484 herewas = newSVpv(s,PL_bufend-s);
5486 s--, herewas = newSVpv(s,d-s);
5487 s += SvCUR(herewas);
5489 tmpstr = NEWSV(87,79);
5490 sv_upgrade(tmpstr, SVt_PVIV);
5495 else if (term == '`') {
5496 op_type = OP_BACKTICK;
5497 SvIVX(tmpstr) = '\\';
5501 PL_multi_start = PL_curcop->cop_line;
5502 PL_multi_open = PL_multi_close = '<';
5503 term = *PL_tokenbuf;
5506 while (s < PL_bufend &&
5507 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5509 PL_curcop->cop_line++;
5511 if (s >= PL_bufend) {
5512 PL_curcop->cop_line = PL_multi_start;
5513 missingterm(PL_tokenbuf);
5515 sv_setpvn(tmpstr,d+1,s-d);
5517 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5519 sv_catpvn(herewas,s,PL_bufend-s);
5520 sv_setsv(PL_linestr,herewas);
5521 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5522 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5525 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5526 while (s >= PL_bufend) { /* multiple line string? */
5528 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5529 PL_curcop->cop_line = PL_multi_start;
5530 missingterm(PL_tokenbuf);
5532 PL_curcop->cop_line++;
5533 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5534 #ifndef PERL_STRICT_CR
5535 if (PL_bufend - PL_linestart >= 2) {
5536 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5537 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5539 PL_bufend[-2] = '\n';
5541 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5543 else if (PL_bufend[-1] == '\r')
5544 PL_bufend[-1] = '\n';
5546 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5547 PL_bufend[-1] = '\n';
5549 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5550 SV *sv = NEWSV(88,0);
5552 sv_upgrade(sv, SVt_PVMG);
5553 sv_setsv(sv,PL_linestr);
5554 av_store(GvAV(PL_curcop->cop_filegv),
5555 (I32)PL_curcop->cop_line,sv);
5557 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5560 sv_catsv(PL_linestr,herewas);
5561 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5565 sv_catsv(tmpstr,PL_linestr);
5568 PL_multi_end = PL_curcop->cop_line;
5570 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5571 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5572 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5574 SvREFCNT_dec(herewas);
5575 PL_lex_stuff = tmpstr;
5576 yylval.ival = op_type;
5581 takes: current position in input buffer
5582 returns: new position in input buffer
5583 side-effects: yylval and lex_op are set.
5588 <FH> read from filehandle
5589 <pkg::FH> read from package qualified filehandle
5590 <pkg'FH> read from package qualified filehandle
5591 <$fh> read from filehandle in $fh
5597 scan_inputsymbol(char *start)
5599 register char *s = start; /* current position in buffer */
5604 d = PL_tokenbuf; /* start of temp holding space */
5605 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5606 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5608 /* die if we didn't have space for the contents of the <>,
5612 if (len >= sizeof PL_tokenbuf)
5613 croak("Excessively long <> operator");
5615 croak("Unterminated <> operator");
5620 Remember, only scalar variables are interpreted as filehandles by
5621 this code. Anything more complex (e.g., <$fh{$num}>) will be
5622 treated as a glob() call.
5623 This code makes use of the fact that except for the $ at the front,
5624 a scalar variable and a filehandle look the same.
5626 if (*d == '$' && d[1]) d++;
5628 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5629 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5632 /* If we've tried to read what we allow filehandles to look like, and
5633 there's still text left, then it must be a glob() and not a getline.
5634 Use scan_str to pull out the stuff between the <> and treat it
5635 as nothing more than a string.
5638 if (d - PL_tokenbuf != len) {
5639 yylval.ival = OP_GLOB;
5641 s = scan_str(start);
5643 croak("Glob not terminated");
5647 /* we're in a filehandle read situation */
5650 /* turn <> into <ARGV> */
5652 (void)strcpy(d,"ARGV");
5654 /* if <$fh>, create the ops to turn the variable into a
5660 /* try to find it in the pad for this block, otherwise find
5661 add symbol table ops
5663 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5664 OP *o = newOP(OP_PADSV, 0);
5666 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5669 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5670 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5671 newUNOP(OP_RV2SV, 0,
5672 newGVOP(OP_GV, 0, gv)));
5674 PL_lex_op->op_flags |= OPf_SPECIAL;
5675 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5676 yylval.ival = OP_NULL;
5679 /* If it's none of the above, it must be a literal filehandle
5680 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5682 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5683 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5684 yylval.ival = OP_NULL;
5693 takes: start position in buffer
5694 returns: position to continue reading from buffer
5695 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5696 updates the read buffer.
5698 This subroutine pulls a string out of the input. It is called for:
5699 q single quotes q(literal text)
5700 ' single quotes 'literal text'
5701 qq double quotes qq(interpolate $here please)
5702 " double quotes "interpolate $here please"
5703 qx backticks qx(/bin/ls -l)
5704 ` backticks `/bin/ls -l`
5705 qw quote words @EXPORT_OK = qw( func() $spam )
5706 m// regexp match m/this/
5707 s/// regexp substitute s/this/that/
5708 tr/// string transliterate tr/this/that/
5709 y/// string transliterate y/this/that/
5710 ($*@) sub prototypes sub foo ($)
5711 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5713 In most of these cases (all but <>, patterns and transliterate)
5714 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5715 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5716 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5719 It skips whitespace before the string starts, and treats the first
5720 character as the delimiter. If the delimiter is one of ([{< then
5721 the corresponding "close" character )]}> is used as the closing
5722 delimiter. It allows quoting of delimiters, and if the string has
5723 balanced delimiters ([{<>}]) it allows nesting.
5725 The lexer always reads these strings into lex_stuff, except in the
5726 case of the operators which take *two* arguments (s/// and tr///)
5727 when it checks to see if lex_stuff is full (presumably with the 1st
5728 arg to s or tr) and if so puts the string into lex_repl.
5733 scan_str(char *start)
5736 SV *sv; /* scalar value: string */
5737 char *tmps; /* temp string, used for delimiter matching */
5738 register char *s = start; /* current position in the buffer */
5739 register char term; /* terminating character */
5740 register char *to; /* current position in the sv's data */
5741 I32 brackets = 1; /* bracket nesting level */
5743 /* skip space before the delimiter */
5747 /* mark where we are, in case we need to report errors */
5750 /* after skipping whitespace, the next character is the terminator */
5752 /* mark where we are */
5753 PL_multi_start = PL_curcop->cop_line;
5754 PL_multi_open = term;
5756 /* find corresponding closing delimiter */
5757 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5759 PL_multi_close = term;
5761 /* create a new SV to hold the contents. 87 is leak category, I'm
5762 assuming. 79 is the SV's initial length. What a random number. */
5764 sv_upgrade(sv, SVt_PVIV);
5766 (void)SvPOK_only(sv); /* validate pointer */
5768 /* move past delimiter and try to read a complete string */
5771 /* extend sv if need be */
5772 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5773 /* set 'to' to the next character in the sv's string */
5774 to = SvPVX(sv)+SvCUR(sv);
5776 /* if open delimiter is the close delimiter read unbridle */
5777 if (PL_multi_open == PL_multi_close) {
5778 for (; s < PL_bufend; s++,to++) {
5779 /* embedded newlines increment the current line number */
5780 if (*s == '\n' && !PL_rsfp)
5781 PL_curcop->cop_line++;
5782 /* handle quoted delimiters */
5783 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5786 /* any other quotes are simply copied straight through */
5790 /* terminate when run out of buffer (the for() condition), or
5791 have found the terminator */
5792 else if (*s == term)
5798 /* if the terminator isn't the same as the start character (e.g.,
5799 matched brackets), we have to allow more in the quoting, and
5800 be prepared for nested brackets.
5803 /* read until we run out of string, or we find the terminator */
5804 for (; s < PL_bufend; s++,to++) {
5805 /* embedded newlines increment the line count */
5806 if (*s == '\n' && !PL_rsfp)
5807 PL_curcop->cop_line++;
5808 /* backslashes can escape the open or closing characters */
5809 if (*s == '\\' && s+1 < PL_bufend) {
5810 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5815 /* allow nested opens and closes */
5816 else if (*s == PL_multi_close && --brackets <= 0)
5818 else if (*s == PL_multi_open)
5823 /* terminate the copied string and update the sv's end-of-string */
5825 SvCUR_set(sv, to - SvPVX(sv));
5828 * this next chunk reads more into the buffer if we're not done yet
5831 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5833 #ifndef PERL_STRICT_CR
5834 if (to - SvPVX(sv) >= 2) {
5835 if ((to[-2] == '\r' && to[-1] == '\n') ||
5836 (to[-2] == '\n' && to[-1] == '\r'))
5840 SvCUR_set(sv, to - SvPVX(sv));
5842 else if (to[-1] == '\r')
5845 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5849 /* if we're out of file, or a read fails, bail and reset the current
5850 line marker so we can report where the unterminated string began
5853 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5855 PL_curcop->cop_line = PL_multi_start;
5858 /* we read a line, so increment our line counter */
5859 PL_curcop->cop_line++;
5861 /* update debugger info */
5862 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5863 SV *sv = NEWSV(88,0);
5865 sv_upgrade(sv, SVt_PVMG);
5866 sv_setsv(sv,PL_linestr);
5867 av_store(GvAV(PL_curcop->cop_filegv),
5868 (I32)PL_curcop->cop_line, sv);
5871 /* having changed the buffer, we must update PL_bufend */
5872 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5875 /* at this point, we have successfully read the delimited string */
5877 PL_multi_end = PL_curcop->cop_line;
5880 /* if we allocated too much space, give some back */
5881 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5882 SvLEN_set(sv, SvCUR(sv) + 1);
5883 Renew(SvPVX(sv), SvLEN(sv), char);
5886 /* decide whether this is the first or second quoted string we've read
5899 takes: pointer to position in buffer
5900 returns: pointer to new position in buffer
5901 side-effects: builds ops for the constant in yylval.op
5903 Read a number in any of the formats that Perl accepts:
5905 0(x[0-7A-F]+)|([0-7]+)|(b[01])
5906 [\d_]+(\.[\d_]*)?[Ee](\d+)
5908 Underbars (_) are allowed in decimal numbers. If -w is on,
5909 underbars before a decimal point must be at three digit intervals.
5911 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5914 If it reads a number without a decimal point or an exponent, it will
5915 try converting the number to an integer and see if it can do so
5916 without loss of precision.
5920 scan_num(char *start)
5922 register char *s = start; /* current position in buffer */
5923 register char *d; /* destination in temp buffer */
5924 register char *e; /* end of temp buffer */
5925 I32 tryiv; /* used to see if it can be an int */
5926 double value; /* number read, as a double */
5927 SV *sv; /* place to put the converted number */
5928 I32 floatit; /* boolean: int or float? */
5929 char *lastub = 0; /* position of last underbar */
5930 static char number_too_long[] = "Number too long";
5932 /* We use the first character to decide what type of number this is */
5936 croak("panic: scan_num");
5938 /* if it starts with a 0, it could be an octal number, a decimal in
5939 0.13 disguise, or a hexadecimal number, or a binary number.
5944 u holds the "number so far"
5945 shift the power of 2 of the base
5946 (hex == 4, octal == 3, binary == 1)
5947 overflowed was the number more than we can hold?
5949 Shift is used when we add a digit. It also serves as an "are
5950 we in octal/hex/binary?" indicator to disallow hex characters
5955 bool overflowed = FALSE;
5961 } else if (s[1] == 'b') {
5965 /* check for a decimal in disguise */
5966 else if (s[1] == '.')
5968 /* so it must be octal */
5973 /* read the rest of the number */
5975 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5979 /* if we don't mention it, we're done */
5988 /* 8 and 9 are not octal */
5991 yyerror("Illegal octal digit");
5994 yyerror("Illegal binary digit");
5998 case '2': case '3': case '4':
5999 case '5': case '6': case '7':
6001 yyerror("Illegal binary digit");
6005 b = *s++ & 15; /* ASCII digit -> value of digit */
6009 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6010 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6011 /* make sure they said 0x */
6016 /* Prepare to put the digit we have onto the end
6017 of the number so far. We check for overflows.
6021 n = u << shift; /* make room for the digit */
6022 if (!overflowed && (n >> shift) != u
6023 && !(PL_hints & HINT_NEW_BINARY)) {
6024 warn("Integer overflow in %s number",
6025 (shift == 4) ? "hex"
6026 : ((shift == 3) ? "octal" : "binary"));
6029 u = n | b; /* add the digit to the end */
6034 /* if we get here, we had success: make a scalar value from
6040 if ( PL_hints & HINT_NEW_BINARY)
6041 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6046 handle decimal numbers.
6047 we're also sent here when we read a 0 as the first digit
6049 case '1': case '2': case '3': case '4': case '5':
6050 case '6': case '7': case '8': case '9': case '.':
6053 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6056 /* read next group of digits and _ and copy into d */
6057 while (isDIGIT(*s) || *s == '_') {
6058 /* skip underscores, checking for misplaced ones
6062 dTHR; /* only for ckWARN */
6063 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6064 warner(WARN_SYNTAX, "Misplaced _ in number");
6068 /* check for end of fixed-length buffer */
6070 croak(number_too_long);
6071 /* if we're ok, copy the character */
6076 /* final misplaced underbar check */
6077 if (lastub && s - lastub != 3) {
6079 if (ckWARN(WARN_SYNTAX))
6080 warner(WARN_SYNTAX, "Misplaced _ in number");
6083 /* read a decimal portion if there is one. avoid
6084 3..5 being interpreted as the number 3. followed
6087 if (*s == '.' && s[1] != '.') {
6091 /* copy, ignoring underbars, until we run out of
6092 digits. Note: no misplaced underbar checks!
6094 for (; isDIGIT(*s) || *s == '_'; s++) {
6095 /* fixed length buffer check */
6097 croak(number_too_long);
6103 /* read exponent part, if present */
6104 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6108 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6109 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6111 /* allow positive or negative exponent */
6112 if (*s == '+' || *s == '-')
6115 /* read digits of exponent (no underbars :-) */
6116 while (isDIGIT(*s)) {
6118 croak(number_too_long);
6123 /* terminate the string */
6126 /* make an sv from the string */
6128 /* reset numeric locale in case we were earlier left in Swaziland */
6129 SET_NUMERIC_STANDARD();
6130 value = atof(PL_tokenbuf);
6133 See if we can make do with an integer value without loss of
6134 precision. We use I_V to cast to an int, because some
6135 compilers have issues. Then we try casting it back and see
6136 if it was the same. We only do this if we know we
6137 specifically read an integer.
6139 Note: if floatit is true, then we don't need to do the
6143 if (!floatit && (double)tryiv == value)
6144 sv_setiv(sv, tryiv);
6146 sv_setnv(sv, value);
6147 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6148 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6149 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6153 /* make the op for the constant and return */
6155 yylval.opval = newSVOP(OP_CONST, 0, sv);
6161 scan_formline(register char *s)
6166 SV *stuff = newSVpv("",0);
6167 bool needargs = FALSE;
6170 if (*s == '.' || *s == '}') {
6172 #ifdef PERL_STRICT_CR
6173 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6175 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6177 if (*t == '\n' || t == PL_bufend)
6180 if (PL_in_eval && !PL_rsfp) {
6181 eol = strchr(s,'\n');
6186 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6188 for (t = s; t < eol; t++) {
6189 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6191 goto enough; /* ~~ must be first line in formline */
6193 if (*t == '@' || *t == '^')
6196 sv_catpvn(stuff, s, eol-s);
6200 s = filter_gets(PL_linestr, PL_rsfp, 0);
6201 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6202 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6205 yyerror("Format not terminated");
6215 PL_lex_state = LEX_NORMAL;
6216 PL_nextval[PL_nexttoke].ival = 0;
6220 PL_lex_state = LEX_FORMLINE;
6221 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6223 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6227 SvREFCNT_dec(stuff);
6228 PL_lex_formbrack = 0;
6239 PL_cshlen = strlen(PL_cshname);
6244 start_subparse(I32 is_format, U32 flags)
6247 I32 oldsavestack_ix = PL_savestack_ix;
6248 CV* outsidecv = PL_compcv;
6252 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6254 save_I32(&PL_subline);
6255 save_item(PL_subname);
6257 SAVESPTR(PL_curpad);
6258 SAVESPTR(PL_comppad);
6259 SAVESPTR(PL_comppad_name);
6260 SAVESPTR(PL_compcv);
6261 SAVEI32(PL_comppad_name_fill);
6262 SAVEI32(PL_min_intro_pending);
6263 SAVEI32(PL_max_intro_pending);
6264 SAVEI32(PL_pad_reset_pending);
6266 PL_compcv = (CV*)NEWSV(1104,0);
6267 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6268 CvFLAGS(PL_compcv) |= flags;
6270 PL_comppad = newAV();
6271 av_push(PL_comppad, Nullsv);
6272 PL_curpad = AvARRAY(PL_comppad);
6273 PL_comppad_name = newAV();
6274 PL_comppad_name_fill = 0;
6275 PL_min_intro_pending = 0;
6277 PL_subline = PL_curcop->cop_line;
6279 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6280 PL_curpad[0] = (SV*)newAV();
6281 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6282 #endif /* USE_THREADS */
6284 comppadlist = newAV();
6285 AvREAL_off(comppadlist);
6286 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6287 av_store(comppadlist, 1, (SV*)PL_comppad);
6289 CvPADLIST(PL_compcv) = comppadlist;
6290 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6292 CvOWNER(PL_compcv) = 0;
6293 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6294 MUTEX_INIT(CvMUTEXP(PL_compcv));
6295 #endif /* USE_THREADS */
6297 return oldsavestack_ix;
6316 char *context = NULL;
6320 if (!yychar || (yychar == ';' && !PL_rsfp))
6322 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6323 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6324 while (isSPACE(*PL_oldoldbufptr))
6326 context = PL_oldoldbufptr;
6327 contlen = PL_bufptr - PL_oldoldbufptr;
6329 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6330 PL_oldbufptr != PL_bufptr) {
6331 while (isSPACE(*PL_oldbufptr))
6333 context = PL_oldbufptr;
6334 contlen = PL_bufptr - PL_oldbufptr;
6336 else if (yychar > 255)
6337 where = "next token ???";
6338 else if ((yychar & 127) == 127) {
6339 if (PL_lex_state == LEX_NORMAL ||
6340 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6341 where = "at end of line";
6342 else if (PL_lex_inpat)
6343 where = "within pattern";
6345 where = "within string";
6348 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6350 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6351 else if (isPRINT_LC(yychar))
6352 sv_catpvf(where_sv, "%c", yychar);
6354 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6355 where = SvPVX(where_sv);
6357 msg = sv_2mortal(newSVpv(s, 0));
6358 sv_catpvf(msg, " at %_ line %ld, ",
6359 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6361 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6363 sv_catpvf(msg, "%s\n", where);
6364 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6366 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6367 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6372 else if (PL_in_eval)
6373 sv_catsv(ERRSV, msg);
6375 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6376 if (++PL_error_count >= 10)
6377 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6379 PL_in_my_stash = Nullhv;