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) {
1092 /* default action is to copy the quoted character */
1094 if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1096 "Unrecognized escape \\%c passed through",
1101 /* \132 indicates an octal constant */
1102 case '0': case '1': case '2': case '3':
1103 case '4': case '5': case '6': case '7':
1104 *d++ = scan_oct(s, 3, &len);
1108 /* \x24 indicates a hex constant */
1112 char* e = strchr(s, '}');
1115 yyerror("Missing right brace on \\x{}");
1120 if (ckWARN(WARN_UTF8))
1122 "Use of \\x{} without utf8 declaration");
1124 /* note: utf always shorter than hex */
1125 d = (char*)uv_to_utf8((U8*)d,
1126 scan_hex(s + 1, e - s - 1, &len));
1131 UV uv = (UV)scan_hex(s, 2, &len);
1132 if (utf && PL_lex_inwhat == OP_TRANS &&
1133 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1135 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1138 if (uv >= 127 && UTF) {
1140 if (ckWARN(WARN_UTF8))
1142 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1151 /* \c is a control character */
1165 /* printf-style backslashes, formfeeds, newlines, etc */
1191 } /* end if (backslash) */
1194 } /* while loop to process each character */
1196 /* terminate the string and set up the sv */
1198 SvCUR_set(sv, d - SvPVX(sv));
1201 /* shrink the sv if we allocated more than we used */
1202 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1203 SvLEN_set(sv, SvCUR(sv) + 1);
1204 Renew(SvPVX(sv), SvLEN(sv), char);
1207 /* return the substring (via yylval) only if we parsed anything */
1208 if (s > PL_bufptr) {
1209 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1210 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1212 ( PL_lex_inwhat == OP_TRANS
1214 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1217 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1223 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1225 intuit_more(register char *s)
1227 if (PL_lex_brackets)
1229 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1231 if (*s != '{' && *s != '[')
1236 /* In a pattern, so maybe we have {n,m}. */
1253 /* On the other hand, maybe we have a character class */
1256 if (*s == ']' || *s == '^')
1259 int weight = 2; /* let's weigh the evidence */
1261 unsigned char un_char = 255, last_un_char;
1262 char *send = strchr(s,']');
1263 char tmpbuf[sizeof PL_tokenbuf * 4];
1265 if (!send) /* has to be an expression */
1268 Zero(seen,256,char);
1271 else if (isDIGIT(*s)) {
1273 if (isDIGIT(s[1]) && s[2] == ']')
1279 for (; s < send; s++) {
1280 last_un_char = un_char;
1281 un_char = (unsigned char)*s;
1286 weight -= seen[un_char] * 10;
1287 if (isALNUM_lazy(s+1)) {
1288 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1289 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1294 else if (*s == '$' && s[1] &&
1295 strchr("[#!%*<>()-=",s[1])) {
1296 if (/*{*/ strchr("])} =",s[2]))
1305 if (strchr("wds]",s[1]))
1307 else if (seen['\''] || seen['"'])
1309 else if (strchr("rnftbxcav",s[1]))
1311 else if (isDIGIT(s[1])) {
1313 while (s[1] && isDIGIT(s[1]))
1323 if (strchr("aA01! ",last_un_char))
1325 if (strchr("zZ79~",s[1]))
1327 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1328 weight -= 5; /* cope with negative subscript */
1331 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1332 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1337 if (keyword(tmpbuf, d - tmpbuf))
1340 if (un_char == last_un_char + 1)
1342 weight -= seen[un_char];
1347 if (weight >= 0) /* probably a character class */
1355 intuit_method(char *start, GV *gv)
1357 char *s = start + (*start == '$');
1358 char tmpbuf[sizeof PL_tokenbuf];
1366 if ((cv = GvCVu(gv))) {
1367 char *proto = SvPVX(cv);
1377 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1378 if (*start == '$') {
1379 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1384 return *s == '(' ? FUNCMETH : METHOD;
1386 if (!keyword(tmpbuf, len)) {
1387 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1392 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1393 if (indirgv && GvCVu(indirgv))
1395 /* filehandle or package name makes it a method */
1396 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1398 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1399 return 0; /* no assumptions -- "=>" quotes bearword */
1401 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1403 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1407 return *s == '(' ? FUNCMETH : METHOD;
1417 char *pdb = PerlEnv_getenv("PERL5DB");
1421 SETERRNO(0,SS$_NORMAL);
1422 return "BEGIN { require 'perl5db.pl' }";
1428 /* Encoded script support. filter_add() effectively inserts a
1429 * 'pre-processing' function into the current source input stream.
1430 * Note that the filter function only applies to the current source file
1431 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1433 * The datasv parameter (which may be NULL) can be used to pass
1434 * private data to this instance of the filter. The filter function
1435 * can recover the SV using the FILTER_DATA macro and use it to
1436 * store private buffers and state information.
1438 * The supplied datasv parameter is upgraded to a PVIO type
1439 * and the IoDIRP field is used to store the function pointer.
1440 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1441 * private use must be set using malloc'd pointers.
1443 static int filter_debug = 0;
1446 filter_add(filter_t funcp, SV *datasv)
1448 if (!funcp){ /* temporary handy debugging hack to be deleted */
1449 filter_debug = atoi((char*)datasv);
1452 if (!PL_rsfp_filters)
1453 PL_rsfp_filters = newAV();
1455 datasv = NEWSV(255,0);
1456 if (!SvUPGRADE(datasv, SVt_PVIO))
1457 die("Can't upgrade filter_add data to SVt_PVIO");
1458 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1461 warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1463 av_unshift(PL_rsfp_filters, 1);
1464 av_store(PL_rsfp_filters, 0, datasv) ;
1469 /* Delete most recently added instance of this filter function. */
1471 filter_del(filter_t funcp)
1474 warn("filter_del func %p", funcp);
1475 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1477 /* if filter is on top of stack (usual case) just pop it off */
1478 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1479 sv_free(av_pop(PL_rsfp_filters));
1483 /* we need to search for the correct entry and clear it */
1484 die("filter_del can only delete in reverse order (currently)");
1488 /* Invoke the n'th filter function for the current rsfp. */
1490 filter_read(int idx, SV *buf_sv, int maxlen)
1493 /* 0 = read one text line */
1498 if (!PL_rsfp_filters)
1500 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1501 /* Provide a default input filter to make life easy. */
1502 /* Note that we append to the line. This is handy. */
1504 warn("filter_read %d: from rsfp\n", idx);
1508 int old_len = SvCUR(buf_sv) ;
1510 /* ensure buf_sv is large enough */
1511 SvGROW(buf_sv, old_len + maxlen) ;
1512 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1513 if (PerlIO_error(PL_rsfp))
1514 return -1; /* error */
1516 return 0 ; /* end of file */
1518 SvCUR_set(buf_sv, old_len + len) ;
1521 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1522 if (PerlIO_error(PL_rsfp))
1523 return -1; /* error */
1525 return 0 ; /* end of file */
1528 return SvCUR(buf_sv);
1530 /* Skip this filter slot if filter has been deleted */
1531 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1533 warn("filter_read %d: skipped (filter deleted)\n", idx);
1534 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1536 /* Get function pointer hidden within datasv */
1537 funcp = (filter_t)IoDIRP(datasv);
1540 warn("filter_read %d: via function %p (%s)\n",
1541 idx, funcp, SvPV(datasv,n_a));
1543 /* Call function. The function is expected to */
1544 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1545 /* Return: <0:error, =0:eof, >0:not eof */
1546 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1550 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1553 if (!PL_rsfp_filters) {
1554 filter_add(win32_textfilter,NULL);
1557 if (PL_rsfp_filters) {
1560 SvCUR_set(sv, 0); /* start with empty line */
1561 if (FILTER_READ(0, sv, 0) > 0)
1562 return ( SvPVX(sv) ) ;
1567 return (sv_gets(sv, fp, append));
1572 static char* exp_name[] =
1573 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1579 Works out what to call the token just pulled out of the input
1580 stream. The yacc parser takes care of taking the ops we return and
1581 stitching them into a tree.
1587 if read an identifier
1588 if we're in a my declaration
1589 croak if they tried to say my($foo::bar)
1590 build the ops for a my() declaration
1591 if it's an access to a my() variable
1592 are we in a sort block?
1593 croak if my($a); $a <=> $b
1594 build ops for access to a my() variable
1595 if in a dq string, and they've said @foo and we can't find @foo
1597 build ops for a bareword
1598 if we already built the token before, use it.
1601 int yylex(PERL_YYLEX_PARAM_DECL)
1611 #ifdef USE_PURE_BISON
1612 yylval_pointer = lvalp;
1613 yychar_pointer = lcharp;
1616 /* check if there's an identifier for us to look at */
1617 if (PL_pending_ident) {
1618 /* pit holds the identifier we read and pending_ident is reset */
1619 char pit = PL_pending_ident;
1620 PL_pending_ident = 0;
1622 /* if we're in a my(), we can't allow dynamics here.
1623 $foo'bar has already been turned into $foo::bar, so
1624 just check for colons.
1626 if it's a legal name, the OP is a PADANY.
1629 if (strchr(PL_tokenbuf,':'))
1630 croak(PL_no_myglob,PL_tokenbuf);
1632 yylval.opval = newOP(OP_PADANY, 0);
1633 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1638 build the ops for accesses to a my() variable.
1640 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1641 then used in a comparison. This catches most, but not
1642 all cases. For instance, it catches
1643 sort { my($a); $a <=> $b }
1645 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1646 (although why you'd do that is anyone's guess).
1649 if (!strchr(PL_tokenbuf,':')) {
1651 /* Check for single character per-thread SVs */
1652 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1653 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1654 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1656 yylval.opval = newOP(OP_THREADSV, 0);
1657 yylval.opval->op_targ = tmp;
1660 #endif /* USE_THREADS */
1661 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1662 /* if it's a sort block and they're naming $a or $b */
1663 if (PL_last_lop_op == OP_SORT &&
1664 PL_tokenbuf[0] == '$' &&
1665 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1668 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1669 d < PL_bufend && *d != '\n';
1672 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1673 croak("Can't use \"my %s\" in sort comparison",
1679 yylval.opval = newOP(OP_PADANY, 0);
1680 yylval.opval->op_targ = tmp;
1686 Whine if they've said @foo in a doublequoted string,
1687 and @foo isn't a variable we can find in the symbol
1690 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1691 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1692 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1693 yyerror(form("In string, %s now must be written as \\%s",
1694 PL_tokenbuf, PL_tokenbuf));
1697 /* build ops for a bareword */
1698 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1699 yylval.opval->op_private = OPpCONST_ENTERED;
1700 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1701 ((PL_tokenbuf[0] == '$') ? SVt_PV
1702 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1707 /* no identifier pending identification */
1709 switch (PL_lex_state) {
1711 case LEX_NORMAL: /* Some compilers will produce faster */
1712 case LEX_INTERPNORMAL: /* code if we comment these out. */
1716 /* when we're already built the next token, just pull it out the queue */
1719 yylval = PL_nextval[PL_nexttoke];
1721 PL_lex_state = PL_lex_defer;
1722 PL_expect = PL_lex_expect;
1723 PL_lex_defer = LEX_NORMAL;
1725 return(PL_nexttype[PL_nexttoke]);
1727 /* interpolated case modifiers like \L \U, including \Q and \E.
1728 when we get here, PL_bufptr is at the \
1730 case LEX_INTERPCASEMOD:
1732 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1733 croak("panic: INTERPCASEMOD");
1735 /* handle \E or end of string */
1736 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1740 if (PL_lex_casemods) {
1741 oldmod = PL_lex_casestack[--PL_lex_casemods];
1742 PL_lex_casestack[PL_lex_casemods] = '\0';
1744 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1746 PL_lex_state = LEX_INTERPCONCAT;
1750 if (PL_bufptr != PL_bufend)
1752 PL_lex_state = LEX_INTERPCONCAT;
1753 return yylex(PERL_YYLEX_PARAM);
1757 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1758 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1759 if (strchr("LU", *s) &&
1760 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1762 PL_lex_casestack[--PL_lex_casemods] = '\0';
1765 if (PL_lex_casemods > 10) {
1766 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1767 if (newlb != PL_lex_casestack) {
1769 PL_lex_casestack = newlb;
1772 PL_lex_casestack[PL_lex_casemods++] = *s;
1773 PL_lex_casestack[PL_lex_casemods] = '\0';
1774 PL_lex_state = LEX_INTERPCONCAT;
1775 PL_nextval[PL_nexttoke].ival = 0;
1778 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1780 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1782 PL_nextval[PL_nexttoke].ival = OP_LC;
1784 PL_nextval[PL_nexttoke].ival = OP_UC;
1786 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1788 croak("panic: yylex");
1791 if (PL_lex_starts) {
1797 return yylex(PERL_YYLEX_PARAM);
1800 case LEX_INTERPPUSH:
1801 return sublex_push();
1803 case LEX_INTERPSTART:
1804 if (PL_bufptr == PL_bufend)
1805 return sublex_done();
1807 PL_lex_dojoin = (*PL_bufptr == '@');
1808 PL_lex_state = LEX_INTERPNORMAL;
1809 if (PL_lex_dojoin) {
1810 PL_nextval[PL_nexttoke].ival = 0;
1813 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1814 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1815 force_next(PRIVATEREF);
1817 force_ident("\"", '$');
1818 #endif /* USE_THREADS */
1819 PL_nextval[PL_nexttoke].ival = 0;
1821 PL_nextval[PL_nexttoke].ival = 0;
1823 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1826 if (PL_lex_starts++) {
1830 return yylex(PERL_YYLEX_PARAM);
1832 case LEX_INTERPENDMAYBE:
1833 if (intuit_more(PL_bufptr)) {
1834 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1840 if (PL_lex_dojoin) {
1841 PL_lex_dojoin = FALSE;
1842 PL_lex_state = LEX_INTERPCONCAT;
1846 case LEX_INTERPCONCAT:
1848 if (PL_lex_brackets)
1849 croak("panic: INTERPCONCAT");
1851 if (PL_bufptr == PL_bufend)
1852 return sublex_done();
1854 if (SvIVX(PL_linestr) == '\'') {
1855 SV *sv = newSVsv(PL_linestr);
1858 else if ( PL_hints & HINT_NEW_RE )
1859 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1860 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1864 s = scan_const(PL_bufptr);
1866 PL_lex_state = LEX_INTERPCASEMOD;
1868 PL_lex_state = LEX_INTERPSTART;
1871 if (s != PL_bufptr) {
1872 PL_nextval[PL_nexttoke] = yylval;
1875 if (PL_lex_starts++)
1879 return yylex(PERL_YYLEX_PARAM);
1883 return yylex(PERL_YYLEX_PARAM);
1885 PL_lex_state = LEX_NORMAL;
1886 s = scan_formline(PL_bufptr);
1887 if (!PL_lex_formbrack)
1893 PL_oldoldbufptr = PL_oldbufptr;
1896 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1902 if (isIDFIRST_lazy(s))
1904 croak("Unrecognized character \\x%02X", *s & 255);
1907 goto fake_eof; /* emulate EOF on ^D or ^Z */
1912 if (PL_lex_brackets)
1913 yyerror("Missing right bracket");
1916 if (s++ < PL_bufend)
1917 goto retry; /* ignore stray nulls */
1920 if (!PL_in_eval && !PL_preambled) {
1921 PL_preambled = TRUE;
1922 sv_setpv(PL_linestr,incl_perldb());
1923 if (SvCUR(PL_linestr))
1924 sv_catpv(PL_linestr,";");
1926 while(AvFILLp(PL_preambleav) >= 0) {
1927 SV *tmpsv = av_shift(PL_preambleav);
1928 sv_catsv(PL_linestr, tmpsv);
1929 sv_catpv(PL_linestr, ";");
1932 sv_free((SV*)PL_preambleav);
1933 PL_preambleav = NULL;
1935 if (PL_minus_n || PL_minus_p) {
1936 sv_catpv(PL_linestr, "LINE: while (<>) {");
1938 sv_catpv(PL_linestr,"chomp;");
1940 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1942 GvIMPORTED_AV_on(gv);
1944 if (strchr("/'\"", *PL_splitstr)
1945 && strchr(PL_splitstr + 1, *PL_splitstr))
1946 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1949 s = "'~#\200\1'"; /* surely one char is unused...*/
1950 while (s[1] && strchr(PL_splitstr, *s)) s++;
1952 sv_catpvf(PL_linestr, "@F=split(%s%c",
1953 "q" + (delim == '\''), delim);
1954 for (s = PL_splitstr; *s; s++) {
1956 sv_catpvn(PL_linestr, "\\", 1);
1957 sv_catpvn(PL_linestr, s, 1);
1959 sv_catpvf(PL_linestr, "%c);", delim);
1963 sv_catpv(PL_linestr,"@F=split(' ');");
1966 sv_catpv(PL_linestr, "\n");
1967 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1968 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1969 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1970 SV *sv = NEWSV(85,0);
1972 sv_upgrade(sv, SVt_PVMG);
1973 sv_setsv(sv,PL_linestr);
1974 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1979 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1982 if (PL_preprocess && !PL_in_eval)
1983 (void)PerlProc_pclose(PL_rsfp);
1984 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1985 PerlIO_clearerr(PL_rsfp);
1987 (void)PerlIO_close(PL_rsfp);
1989 PL_doextract = FALSE;
1991 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1992 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1993 sv_catpv(PL_linestr,";}");
1994 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1995 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1996 PL_minus_n = PL_minus_p = 0;
1999 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2000 sv_setpv(PL_linestr,"");
2001 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2004 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2005 PL_doextract = FALSE;
2007 /* Incest with pod. */
2008 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2009 sv_setpv(PL_linestr, "");
2010 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2011 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2012 PL_doextract = FALSE;
2016 } while (PL_doextract);
2017 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2018 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2019 SV *sv = NEWSV(85,0);
2021 sv_upgrade(sv, SVt_PVMG);
2022 sv_setsv(sv,PL_linestr);
2023 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2025 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2026 if (PL_curcop->cop_line == 1) {
2027 while (s < PL_bufend && isSPACE(*s))
2029 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2033 if (*s == '#' && *(s+1) == '!')
2035 #ifdef ALTERNATE_SHEBANG
2037 static char as[] = ALTERNATE_SHEBANG;
2038 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2039 d = s + (sizeof(as) - 1);
2041 #endif /* ALTERNATE_SHEBANG */
2050 while (*d && !isSPACE(*d))
2054 #ifdef ARG_ZERO_IS_SCRIPT
2055 if (ipathend > ipath) {
2057 * HP-UX (at least) sets argv[0] to the script name,
2058 * which makes $^X incorrect. And Digital UNIX and Linux,
2059 * at least, set argv[0] to the basename of the Perl
2060 * interpreter. So, having found "#!", we'll set it right.
2062 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2063 assert(SvPOK(x) || SvGMAGICAL(x));
2064 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2065 sv_setpvn(x, ipath, ipathend - ipath);
2068 TAINT_NOT; /* $^X is always tainted, but that's OK */
2070 #endif /* ARG_ZERO_IS_SCRIPT */
2075 d = instr(s,"perl -");
2077 d = instr(s,"perl");
2078 #ifdef ALTERNATE_SHEBANG
2080 * If the ALTERNATE_SHEBANG on this system starts with a
2081 * character that can be part of a Perl expression, then if
2082 * we see it but not "perl", we're probably looking at the
2083 * start of Perl code, not a request to hand off to some
2084 * other interpreter. Similarly, if "perl" is there, but
2085 * not in the first 'word' of the line, we assume the line
2086 * contains the start of the Perl program.
2088 if (d && *s != '#') {
2090 while (*c && !strchr("; \t\r\n\f\v#", *c))
2093 d = Nullch; /* "perl" not in first word; ignore */
2095 *s = '#'; /* Don't try to parse shebang line */
2097 #endif /* ALTERNATE_SHEBANG */
2102 !instr(s,"indir") &&
2103 instr(PL_origargv[0],"perl"))
2109 while (s < PL_bufend && isSPACE(*s))
2111 if (s < PL_bufend) {
2112 Newz(899,newargv,PL_origargc+3,char*);
2114 while (s < PL_bufend && !isSPACE(*s))
2117 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2120 newargv = PL_origargv;
2122 execv(ipath, newargv);
2123 croak("Can't exec %s", ipath);
2126 U32 oldpdb = PL_perldb;
2127 bool oldn = PL_minus_n;
2128 bool oldp = PL_minus_p;
2130 while (*d && !isSPACE(*d)) d++;
2131 while (*d == ' ' || *d == '\t') d++;
2135 if (*d == 'M' || *d == 'm') {
2137 while (*d && !isSPACE(*d)) d++;
2138 croak("Too late for \"-%.*s\" option",
2141 d = moreswitches(d);
2143 if (PERLDB_LINE && !oldpdb ||
2144 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2145 /* if we have already added "LINE: while (<>) {",
2146 we must not do it again */
2148 sv_setpv(PL_linestr, "");
2149 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2150 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2151 PL_preambled = FALSE;
2153 (void)gv_fetchfile(PL_origfilename);
2160 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2162 PL_lex_state = LEX_FORMLINE;
2163 return yylex(PERL_YYLEX_PARAM);
2167 #ifdef PERL_STRICT_CR
2168 warn("Illegal character \\%03o (carriage return)", '\r');
2170 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2172 case ' ': case '\t': case '\f': case 013:
2177 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2179 while (s < d && *s != '\n')
2184 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2186 PL_lex_state = LEX_FORMLINE;
2187 return yylex(PERL_YYLEX_PARAM);
2196 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2201 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2204 if (strnEQ(s,"=>",2)) {
2205 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2206 OPERATOR('-'); /* unary minus */
2208 PL_last_uni = PL_oldbufptr;
2209 PL_last_lop_op = OP_FTEREAD; /* good enough */
2211 case 'r': FTST(OP_FTEREAD);
2212 case 'w': FTST(OP_FTEWRITE);
2213 case 'x': FTST(OP_FTEEXEC);
2214 case 'o': FTST(OP_FTEOWNED);
2215 case 'R': FTST(OP_FTRREAD);
2216 case 'W': FTST(OP_FTRWRITE);
2217 case 'X': FTST(OP_FTREXEC);
2218 case 'O': FTST(OP_FTROWNED);
2219 case 'e': FTST(OP_FTIS);
2220 case 'z': FTST(OP_FTZERO);
2221 case 's': FTST(OP_FTSIZE);
2222 case 'f': FTST(OP_FTFILE);
2223 case 'd': FTST(OP_FTDIR);
2224 case 'l': FTST(OP_FTLINK);
2225 case 'p': FTST(OP_FTPIPE);
2226 case 'S': FTST(OP_FTSOCK);
2227 case 'u': FTST(OP_FTSUID);
2228 case 'g': FTST(OP_FTSGID);
2229 case 'k': FTST(OP_FTSVTX);
2230 case 'b': FTST(OP_FTBLK);
2231 case 'c': FTST(OP_FTCHR);
2232 case 't': FTST(OP_FTTTY);
2233 case 'T': FTST(OP_FTTEXT);
2234 case 'B': FTST(OP_FTBINARY);
2235 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2236 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2237 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2239 croak("Unrecognized file test: -%c", (int)tmp);
2246 if (PL_expect == XOPERATOR)
2251 else if (*s == '>') {
2254 if (isIDFIRST_lazy(s)) {
2255 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2263 if (PL_expect == XOPERATOR)
2266 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2268 OPERATOR('-'); /* unary minus */
2275 if (PL_expect == XOPERATOR)
2280 if (PL_expect == XOPERATOR)
2283 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2289 if (PL_expect != XOPERATOR) {
2290 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2291 PL_expect = XOPERATOR;
2292 force_ident(PL_tokenbuf, '*');
2305 if (PL_expect == XOPERATOR) {
2309 PL_tokenbuf[0] = '%';
2310 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2311 if (!PL_tokenbuf[1]) {
2313 yyerror("Final % should be \\% or %name");
2316 PL_pending_ident = '%';
2338 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2339 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2344 if (PL_curcop->cop_line < PL_copline)
2345 PL_copline = PL_curcop->cop_line;
2356 if (PL_lex_brackets <= 0)
2357 yyerror("Unmatched right bracket");
2360 if (PL_lex_state == LEX_INTERPNORMAL) {
2361 if (PL_lex_brackets == 0) {
2362 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2363 PL_lex_state = LEX_INTERPEND;
2370 if (PL_lex_brackets > 100) {
2371 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2372 if (newlb != PL_lex_brackstack) {
2374 PL_lex_brackstack = newlb;
2377 switch (PL_expect) {
2379 if (PL_lex_formbrack) {
2383 if (PL_oldoldbufptr == PL_last_lop)
2384 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2386 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2387 OPERATOR(HASHBRACK);
2389 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2392 PL_tokenbuf[0] = '\0';
2393 if (d < PL_bufend && *d == '-') {
2394 PL_tokenbuf[0] = '-';
2396 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2399 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2400 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2402 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2405 char minus = (PL_tokenbuf[0] == '-');
2406 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2413 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2417 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2422 if (PL_oldoldbufptr == PL_last_lop)
2423 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2425 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2428 OPERATOR(HASHBRACK);
2429 /* This hack serves to disambiguate a pair of curlies
2430 * as being a block or an anon hash. Normally, expectation
2431 * determines that, but in cases where we're not in a
2432 * position to expect anything in particular (like inside
2433 * eval"") we have to resolve the ambiguity. This code
2434 * covers the case where the first term in the curlies is a
2435 * quoted string. Most other cases need to be explicitly
2436 * disambiguated by prepending a `+' before the opening
2437 * curly in order to force resolution as an anon hash.
2439 * XXX should probably propagate the outer expectation
2440 * into eval"" to rely less on this hack, but that could
2441 * potentially break current behavior of eval"".
2445 if (*s == '\'' || *s == '"' || *s == '`') {
2446 /* common case: get past first string, handling escapes */
2447 for (t++; t < PL_bufend && *t != *s;)
2448 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2452 else if (*s == 'q') {
2455 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2456 && !isALNUM(*t)))) {
2458 char open, close, term;
2461 while (t < PL_bufend && isSPACE(*t))
2465 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2469 for (t++; t < PL_bufend; t++) {
2470 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2472 else if (*t == open)
2476 for (t++; t < PL_bufend; t++) {
2477 if (*t == '\\' && t+1 < PL_bufend)
2479 else if (*t == close && --brackets <= 0)
2481 else if (*t == open)
2487 else if (isIDFIRST_lazy(s)) {
2488 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2490 while (t < PL_bufend && isSPACE(*t))
2492 /* if comma follows first term, call it an anon hash */
2493 /* XXX it could be a comma expression with loop modifiers */
2494 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2495 || (*t == '=' && t[1] == '>')))
2496 OPERATOR(HASHBRACK);
2497 if (PL_expect == XREF)
2498 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2500 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2506 yylval.ival = PL_curcop->cop_line;
2507 if (isSPACE(*s) || *s == '#')
2508 PL_copline = NOLINE; /* invalidate current command line number */
2513 if (PL_lex_brackets <= 0)
2514 yyerror("Unmatched right bracket");
2516 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2517 if (PL_lex_brackets < PL_lex_formbrack)
2518 PL_lex_formbrack = 0;
2519 if (PL_lex_state == LEX_INTERPNORMAL) {
2520 if (PL_lex_brackets == 0) {
2521 if (PL_lex_fakebrack) {
2522 PL_lex_state = LEX_INTERPEND;
2524 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2526 if (*s == '-' && s[1] == '>')
2527 PL_lex_state = LEX_INTERPENDMAYBE;
2528 else if (*s != '[' && *s != '{')
2529 PL_lex_state = LEX_INTERPEND;
2532 if (PL_lex_brackets < PL_lex_fakebrack) {
2534 PL_lex_fakebrack = 0;
2535 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2545 if (PL_expect == XOPERATOR) {
2546 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2547 PL_curcop->cop_line--;
2548 warner(WARN_SEMICOLON, PL_warn_nosemi);
2549 PL_curcop->cop_line++;
2554 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2556 PL_expect = XOPERATOR;
2557 force_ident(PL_tokenbuf, '&');
2561 yylval.ival = (OPpENTERSUB_AMPER<<8);
2580 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2581 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2583 if (PL_expect == XSTATE && isALPHA(tmp) &&
2584 (s == PL_linestart+1 || s[-2] == '\n') )
2586 if (PL_in_eval && !PL_rsfp) {
2591 if (strnEQ(s,"=cut",4)) {
2605 PL_doextract = TRUE;
2608 if (PL_lex_brackets < PL_lex_formbrack) {
2610 #ifdef PERL_STRICT_CR
2611 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2613 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2615 if (*t == '\n' || *t == '#') {
2633 if (PL_expect != XOPERATOR) {
2634 if (s[1] != '<' && !strchr(s,'>'))
2637 s = scan_heredoc(s);
2639 s = scan_inputsymbol(s);
2640 TERM(sublex_start());
2645 SHop(OP_LEFT_SHIFT);
2659 SHop(OP_RIGHT_SHIFT);
2668 if (PL_expect == XOPERATOR) {
2669 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2672 return ','; /* grandfather non-comma-format format */
2676 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2677 if (PL_expect == XOPERATOR)
2678 no_op("Array length", PL_bufptr);
2679 PL_tokenbuf[0] = '@';
2680 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2682 if (!PL_tokenbuf[1])
2684 PL_expect = XOPERATOR;
2685 PL_pending_ident = '#';
2689 if (PL_expect == XOPERATOR)
2690 no_op("Scalar", PL_bufptr);
2691 PL_tokenbuf[0] = '$';
2692 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2693 if (!PL_tokenbuf[1]) {
2695 yyerror("Final $ should be \\$ or $name");
2699 /* This kludge not intended to be bulletproof. */
2700 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2701 yylval.opval = newSVOP(OP_CONST, 0,
2702 newSViv((IV)PL_compiling.cop_arybase));
2703 yylval.opval->op_private = OPpCONST_ARYBASE;
2708 if (PL_lex_state == LEX_NORMAL)
2711 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2714 PL_tokenbuf[0] = '@';
2715 if (ckWARN(WARN_SYNTAX)) {
2717 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2720 PL_bufptr = skipspace(PL_bufptr);
2721 while (t < PL_bufend && *t != ']')
2724 "Multidimensional syntax %.*s not supported",
2725 (t - PL_bufptr) + 1, PL_bufptr);
2729 else if (*s == '{') {
2730 PL_tokenbuf[0] = '%';
2731 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2732 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2734 char tmpbuf[sizeof PL_tokenbuf];
2736 for (t++; isSPACE(*t); t++) ;
2737 if (isIDFIRST_lazy(t)) {
2738 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2739 for (; isSPACE(*t); t++) ;
2740 if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
2742 "You need to quote \"%s\"", tmpbuf);
2748 PL_expect = XOPERATOR;
2749 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2750 bool islop = (PL_last_lop == PL_oldoldbufptr);
2751 if (!islop || PL_last_lop_op == OP_GREPSTART)
2752 PL_expect = XOPERATOR;
2753 else if (strchr("$@\"'`q", *s))
2754 PL_expect = XTERM; /* e.g. print $fh "foo" */
2755 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2756 PL_expect = XTERM; /* e.g. print $fh &sub */
2757 else if (isIDFIRST_lazy(s)) {
2758 char tmpbuf[sizeof PL_tokenbuf];
2759 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2760 if (tmp = keyword(tmpbuf, len)) {
2761 /* binary operators exclude handle interpretations */
2773 PL_expect = XTERM; /* e.g. print $fh length() */
2778 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2779 if (gv && GvCVu(gv))
2780 PL_expect = XTERM; /* e.g. print $fh subr() */
2783 else if (isDIGIT(*s))
2784 PL_expect = XTERM; /* e.g. print $fh 3 */
2785 else if (*s == '.' && isDIGIT(s[1]))
2786 PL_expect = XTERM; /* e.g. print $fh .3 */
2787 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2788 PL_expect = XTERM; /* e.g. print $fh -1 */
2789 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2790 PL_expect = XTERM; /* print $fh <<"EOF" */
2792 PL_pending_ident = '$';
2796 if (PL_expect == XOPERATOR)
2798 PL_tokenbuf[0] = '@';
2799 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2800 if (!PL_tokenbuf[1]) {
2802 yyerror("Final @ should be \\@ or @name");
2805 if (PL_lex_state == LEX_NORMAL)
2807 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2809 PL_tokenbuf[0] = '%';
2811 /* Warn about @ where they meant $. */
2812 if (ckWARN(WARN_SYNTAX)) {
2813 if (*s == '[' || *s == '{') {
2815 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2817 if (*t == '}' || *t == ']') {
2819 PL_bufptr = skipspace(PL_bufptr);
2821 "Scalar value %.*s better written as $%.*s",
2822 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2827 PL_pending_ident = '@';
2830 case '/': /* may either be division or pattern */
2831 case '?': /* may either be conditional or pattern */
2832 if (PL_expect != XOPERATOR) {
2833 /* Disable warning on "study /blah/" */
2834 if (PL_oldoldbufptr == PL_last_uni
2835 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2836 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2838 s = scan_pat(s,OP_MATCH);
2839 TERM(sublex_start());
2847 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2848 #ifdef PERL_STRICT_CR
2851 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2853 && (s == PL_linestart || s[-1] == '\n') )
2855 PL_lex_formbrack = 0;
2859 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2865 yylval.ival = OPf_SPECIAL;
2871 if (PL_expect != XOPERATOR)
2876 case '0': case '1': case '2': case '3': case '4':
2877 case '5': case '6': case '7': case '8': case '9':
2879 if (PL_expect == XOPERATOR)
2885 if (PL_expect == XOPERATOR) {
2886 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2889 return ','; /* grandfather non-comma-format format */
2895 missingterm((char*)0);
2896 yylval.ival = OP_CONST;
2897 TERM(sublex_start());
2901 if (PL_expect == XOPERATOR) {
2902 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2905 return ','; /* grandfather non-comma-format format */
2911 missingterm((char*)0);
2912 yylval.ival = OP_CONST;
2913 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2914 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2915 yylval.ival = OP_STRINGIFY;
2919 TERM(sublex_start());
2923 if (PL_expect == XOPERATOR)
2924 no_op("Backticks",s);
2926 missingterm((char*)0);
2927 yylval.ival = OP_BACKTICK;
2929 TERM(sublex_start());
2933 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2934 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2936 if (PL_expect == XOPERATOR)
2937 no_op("Backslash",s);
2941 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2981 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2983 /* Some keywords can be followed by any delimiter, including ':' */
2984 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2985 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2986 (PL_tokenbuf[0] == 'q' &&
2987 strchr("qwxr", PL_tokenbuf[1]))));
2989 /* x::* is just a word, unless x is "CORE" */
2990 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2994 while (d < PL_bufend && isSPACE(*d))
2995 d++; /* no comments skipped here, or s### is misparsed */
2997 /* Is this a label? */
2998 if (!tmp && PL_expect == XSTATE
2999 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3001 yylval.pval = savepv(PL_tokenbuf);
3006 /* Check for keywords */
3007 tmp = keyword(PL_tokenbuf, len);
3009 /* Is this a word before a => operator? */
3010 if (strnEQ(d,"=>",2)) {
3012 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3013 yylval.opval->op_private = OPpCONST_BARE;
3017 if (tmp < 0) { /* second-class keyword? */
3018 GV *ogv = Nullgv; /* override (winner) */
3019 GV *hgv = Nullgv; /* hidden (loser) */
3020 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3022 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3025 if (GvIMPORTED_CV(gv))
3027 else if (! CvMETHOD(cv))
3031 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3032 (gv = *gvp) != (GV*)&PL_sv_undef &&
3033 GvCVu(gv) && GvIMPORTED_CV(gv))
3039 tmp = 0; /* overridden by import or by GLOBAL */
3042 && -tmp==KEY_lock /* XXX generalizable kludge */
3043 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3045 tmp = 0; /* any sub overrides "weak" keyword */
3047 else { /* no override */
3051 if (ckWARN(WARN_AMBIGUOUS) && hgv
3052 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3053 warner(WARN_AMBIGUOUS,
3054 "Ambiguous call resolved as CORE::%s(), %s",
3055 GvENAME(hgv), "qualify as such or use &");
3062 default: /* not a keyword */
3065 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3067 /* Get the rest if it looks like a package qualifier */
3069 if (*s == '\'' || *s == ':' && s[1] == ':') {
3071 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3074 croak("Bad name after %s%s", PL_tokenbuf,
3075 *s == '\'' ? "'" : "::");
3079 if (PL_expect == XOPERATOR) {
3080 if (PL_bufptr == PL_linestart) {
3081 PL_curcop->cop_line--;
3082 warner(WARN_SEMICOLON, PL_warn_nosemi);
3083 PL_curcop->cop_line++;
3086 no_op("Bareword",s);
3089 /* Look for a subroutine with this name in current package,
3090 unless name is "Foo::", in which case Foo is a bearword
3091 (and a package name). */
3094 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3096 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3098 "Bareword \"%s\" refers to nonexistent package",
3101 PL_tokenbuf[len] = '\0';
3108 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3111 /* if we saw a global override before, get the right name */
3114 sv = newSVpv("CORE::GLOBAL::",14);
3115 sv_catpv(sv,PL_tokenbuf);
3118 sv = newSVpv(PL_tokenbuf,0);
3120 /* Presume this is going to be a bareword of some sort. */
3123 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3124 yylval.opval->op_private = OPpCONST_BARE;
3126 /* And if "Foo::", then that's what it certainly is. */
3131 /* See if it's the indirect object for a list operator. */
3133 if (PL_oldoldbufptr &&
3134 PL_oldoldbufptr < PL_bufptr &&
3135 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3136 /* NO SKIPSPACE BEFORE HERE! */
3138 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3139 || (PL_last_lop_op == OP_ENTERSUB
3141 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3143 bool immediate_paren = *s == '(';
3145 /* (Now we can afford to cross potential line boundary.) */
3148 /* Two barewords in a row may indicate method call. */
3150 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3153 /* If not a declared subroutine, it's an indirect object. */
3154 /* (But it's an indir obj regardless for sort.) */
3156 if ((PL_last_lop_op == OP_SORT ||
3157 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3158 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3159 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3164 /* If followed by a paren, it's certainly a subroutine. */
3166 PL_expect = XOPERATOR;
3170 if (gv && GvCVu(gv)) {
3172 if ((cv = GvCV(gv)) && SvPOK(cv))
3173 PL_last_proto = SvPV((SV*)cv, n_a);
3174 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3175 if (*d == ')' && (sv = cv_const_sv(cv))) {
3180 PL_nextval[PL_nexttoke].opval = yylval.opval;
3181 PL_expect = XOPERATOR;
3184 PL_last_lop_op = OP_ENTERSUB;
3188 /* If followed by var or block, call it a method (unless sub) */
3190 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3191 PL_last_lop = PL_oldbufptr;
3192 PL_last_lop_op = OP_METHOD;
3196 /* If followed by a bareword, see if it looks like indir obj. */
3198 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3201 /* Not a method, so call it a subroutine (if defined) */
3203 if (gv && GvCVu(gv)) {
3205 if (lastchar == '-')
3206 warn("Ambiguous use of -%s resolved as -&%s()",
3207 PL_tokenbuf, PL_tokenbuf);
3208 PL_last_lop = PL_oldbufptr;
3209 PL_last_lop_op = OP_ENTERSUB;
3210 /* Check for a constant sub */
3212 if ((sv = cv_const_sv(cv))) {
3214 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3215 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3216 yylval.opval->op_private = 0;
3220 /* Resolve to GV now. */
3221 op_free(yylval.opval);
3222 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3223 PL_last_lop_op = OP_ENTERSUB;
3224 /* Is there a prototype? */
3227 PL_last_proto = SvPV((SV*)cv, len);
3230 if (strEQ(PL_last_proto, "$"))
3232 if (*PL_last_proto == '&' && *s == '{') {
3233 sv_setpv(PL_subname,"__ANON__");
3237 PL_last_proto = NULL;
3238 PL_nextval[PL_nexttoke].opval = yylval.opval;
3244 if (PL_hints & HINT_STRICT_SUBS &&
3247 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3248 PL_last_lop_op != OP_ACCEPT &&
3249 PL_last_lop_op != OP_PIPE_OP &&
3250 PL_last_lop_op != OP_SOCKPAIR &&
3251 !(PL_last_lop_op == OP_ENTERSUB
3253 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3256 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3261 /* Call it a bare word */
3264 if (ckWARN(WARN_RESERVED)) {
3265 if (lastchar != '-') {
3266 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3268 warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
3273 if (lastchar && strchr("*%&", lastchar)) {
3274 warn("Operator or semicolon missing before %c%s",
3275 lastchar, PL_tokenbuf);
3276 warn("Ambiguous use of %c resolved as operator %c",
3277 lastchar, lastchar);
3283 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3284 newSVsv(GvSV(PL_curcop->cop_filegv)));
3288 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3289 newSVpvf("%ld", (long)PL_curcop->cop_line));
3292 case KEY___PACKAGE__:
3293 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3295 ? newSVsv(PL_curstname)
3304 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3305 char *pname = "main";
3306 if (PL_tokenbuf[2] == 'D')
3307 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3308 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3311 GvIOp(gv) = newIO();
3312 IoIFP(GvIOp(gv)) = PL_rsfp;
3313 #if defined(HAS_FCNTL) && defined(F_SETFD)
3315 int fd = PerlIO_fileno(PL_rsfp);
3316 fcntl(fd,F_SETFD,fd >= 3);
3319 /* Mark this internal pseudo-handle as clean */
3320 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3322 IoTYPE(GvIOp(gv)) = '|';
3323 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3324 IoTYPE(GvIOp(gv)) = '-';
3326 IoTYPE(GvIOp(gv)) = '<';
3337 if (PL_expect == XSTATE) {
3344 if (*s == ':' && s[1] == ':') {
3347 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3348 tmp = keyword(PL_tokenbuf, len);
3362 LOP(OP_ACCEPT,XTERM);
3368 LOP(OP_ATAN2,XTERM);
3377 LOP(OP_BLESS,XTERM);
3386 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3403 if (!PL_cryptseen++)
3406 LOP(OP_CRYPT,XTERM);
3409 if (ckWARN(WARN_OCTAL)) {
3410 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3411 if (*d != '0' && isDIGIT(*d))
3412 yywarn("chmod: mode argument is missing initial 0");
3414 LOP(OP_CHMOD,XTERM);
3417 LOP(OP_CHOWN,XTERM);
3420 LOP(OP_CONNECT,XTERM);
3436 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3440 PL_hints |= HINT_BLOCK_SCOPE;
3450 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3451 LOP(OP_DBMOPEN,XTERM);
3457 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3464 yylval.ival = PL_curcop->cop_line;
3478 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3479 UNIBRACK(OP_ENTEREVAL);
3494 case KEY_endhostent:
3500 case KEY_endservent:
3503 case KEY_endprotoent:
3514 yylval.ival = PL_curcop->cop_line;
3516 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3518 if ((PL_bufend - p) >= 3 &&
3519 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3522 if (isIDFIRST_lazy(p))
3523 croak("Missing $ on loop variable");
3528 LOP(OP_FORMLINE,XTERM);
3534 LOP(OP_FCNTL,XTERM);
3540 LOP(OP_FLOCK,XTERM);
3549 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3552 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3567 case KEY_getpriority:
3568 LOP(OP_GETPRIORITY,XTERM);
3570 case KEY_getprotobyname:
3573 case KEY_getprotobynumber:
3574 LOP(OP_GPBYNUMBER,XTERM);
3576 case KEY_getprotoent:
3588 case KEY_getpeername:
3589 UNI(OP_GETPEERNAME);
3591 case KEY_gethostbyname:
3594 case KEY_gethostbyaddr:
3595 LOP(OP_GHBYADDR,XTERM);
3597 case KEY_gethostent:
3600 case KEY_getnetbyname:
3603 case KEY_getnetbyaddr:
3604 LOP(OP_GNBYADDR,XTERM);
3609 case KEY_getservbyname:
3610 LOP(OP_GSBYNAME,XTERM);
3612 case KEY_getservbyport:
3613 LOP(OP_GSBYPORT,XTERM);
3615 case KEY_getservent:
3618 case KEY_getsockname:
3619 UNI(OP_GETSOCKNAME);
3621 case KEY_getsockopt:
3622 LOP(OP_GSOCKOPT,XTERM);
3644 yylval.ival = PL_curcop->cop_line;
3648 LOP(OP_INDEX,XTERM);
3654 LOP(OP_IOCTL,XTERM);
3666 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3697 LOP(OP_LISTEN,XTERM);
3706 s = scan_pat(s,OP_MATCH);
3707 TERM(sublex_start());
3710 LOP(OP_MAPSTART, XREF);
3713 LOP(OP_MKDIR,XTERM);
3716 LOP(OP_MSGCTL,XTERM);
3719 LOP(OP_MSGGET,XTERM);
3722 LOP(OP_MSGRCV,XTERM);
3725 LOP(OP_MSGSND,XTERM);
3730 if (isIDFIRST_lazy(s)) {
3731 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3732 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3733 if (!PL_in_my_stash) {
3736 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3743 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3750 if (PL_expect != XSTATE)
3751 yyerror("\"no\" not allowed in expression");
3752 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3753 s = force_version(s);
3762 if (isIDFIRST_lazy(s)) {
3764 for (d = s; isALNUM_lazy(d); d++) ;
3766 if (strchr("|&*+-=!?:.", *t))
3767 warn("Precedence problem: open %.*s should be open(%.*s)",
3773 yylval.ival = OP_OR;
3783 LOP(OP_OPEN_DIR,XTERM);
3786 checkcomma(s,PL_tokenbuf,"filehandle");
3790 checkcomma(s,PL_tokenbuf,"filehandle");
3809 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3813 LOP(OP_PIPE_OP,XTERM);
3818 missingterm((char*)0);
3819 yylval.ival = OP_CONST;
3820 TERM(sublex_start());
3828 missingterm((char*)0);
3829 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3830 d = SvPV_force(PL_lex_stuff, len);
3831 for (; len; --len, ++d) {
3834 "Possible attempt to separate words with commas");
3839 "Possible attempt to put comments in qw() list");
3845 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3846 PL_lex_stuff = Nullsv;
3849 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3852 yylval.ival = OP_SPLIT;
3856 PL_last_lop = PL_oldbufptr;
3857 PL_last_lop_op = OP_SPLIT;
3863 missingterm((char*)0);
3864 yylval.ival = OP_STRINGIFY;
3865 if (SvIVX(PL_lex_stuff) == '\'')
3866 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3867 TERM(sublex_start());
3870 s = scan_pat(s,OP_QR);
3871 TERM(sublex_start());
3876 missingterm((char*)0);
3877 yylval.ival = OP_BACKTICK;
3879 TERM(sublex_start());
3885 *PL_tokenbuf = '\0';
3886 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3887 if (isIDFIRST_lazy(PL_tokenbuf))
3888 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3890 yyerror("<> should be quotes");
3897 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3901 LOP(OP_RENAME,XTERM);
3910 LOP(OP_RINDEX,XTERM);
3933 LOP(OP_REVERSE,XTERM);
3944 TERM(sublex_start());
3946 TOKEN(1); /* force error */
3955 LOP(OP_SELECT,XTERM);
3961 LOP(OP_SEMCTL,XTERM);
3964 LOP(OP_SEMGET,XTERM);
3967 LOP(OP_SEMOP,XTERM);
3973 LOP(OP_SETPGRP,XTERM);
3975 case KEY_setpriority:
3976 LOP(OP_SETPRIORITY,XTERM);
3978 case KEY_sethostent:
3984 case KEY_setservent:
3987 case KEY_setprotoent:
3997 LOP(OP_SEEKDIR,XTERM);
3999 case KEY_setsockopt:
4000 LOP(OP_SSOCKOPT,XTERM);
4006 LOP(OP_SHMCTL,XTERM);
4009 LOP(OP_SHMGET,XTERM);
4012 LOP(OP_SHMREAD,XTERM);
4015 LOP(OP_SHMWRITE,XTERM);
4018 LOP(OP_SHUTDOWN,XTERM);
4027 LOP(OP_SOCKET,XTERM);
4029 case KEY_socketpair:
4030 LOP(OP_SOCKPAIR,XTERM);
4033 checkcomma(s,PL_tokenbuf,"subroutine name");
4035 if (*s == ';' || *s == ')') /* probably a close */
4036 croak("sort is now a reserved word");
4038 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4042 LOP(OP_SPLIT,XTERM);
4045 LOP(OP_SPRINTF,XTERM);
4048 LOP(OP_SPLICE,XTERM);
4064 LOP(OP_SUBSTR,XTERM);
4071 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4072 char tmpbuf[sizeof PL_tokenbuf];
4074 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4075 if (strchr(tmpbuf, ':'))
4076 sv_setpv(PL_subname, tmpbuf);
4078 sv_setsv(PL_subname,PL_curstname);
4079 sv_catpvn(PL_subname,"::",2);
4080 sv_catpvn(PL_subname,tmpbuf,len);
4082 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4086 PL_expect = XTERMBLOCK;
4087 sv_setpv(PL_subname,"?");
4090 if (tmp == KEY_format) {
4093 PL_lex_formbrack = PL_lex_brackets + 1;
4097 /* Look for a prototype */
4104 SvREFCNT_dec(PL_lex_stuff);
4105 PL_lex_stuff = Nullsv;
4106 croak("Prototype not terminated");
4109 d = SvPVX(PL_lex_stuff);
4111 for (p = d; *p; ++p) {
4116 SvCUR(PL_lex_stuff) = tmp;
4119 PL_nextval[1] = PL_nextval[0];
4120 PL_nexttype[1] = PL_nexttype[0];
4121 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4122 PL_nexttype[0] = THING;
4123 if (PL_nexttoke == 1) {
4124 PL_lex_defer = PL_lex_state;
4125 PL_lex_expect = PL_expect;
4126 PL_lex_state = LEX_KNOWNEXT;
4128 PL_lex_stuff = Nullsv;
4131 if (*SvPV(PL_subname,n_a) == '?') {
4132 sv_setpv(PL_subname,"__ANON__");
4139 LOP(OP_SYSTEM,XREF);
4142 LOP(OP_SYMLINK,XTERM);
4145 LOP(OP_SYSCALL,XTERM);
4148 LOP(OP_SYSOPEN,XTERM);
4151 LOP(OP_SYSSEEK,XTERM);
4154 LOP(OP_SYSREAD,XTERM);
4157 LOP(OP_SYSWRITE,XTERM);
4161 TERM(sublex_start());
4182 LOP(OP_TRUNCATE,XTERM);
4194 yylval.ival = PL_curcop->cop_line;
4198 yylval.ival = PL_curcop->cop_line;
4202 LOP(OP_UNLINK,XTERM);
4208 LOP(OP_UNPACK,XTERM);
4211 LOP(OP_UTIME,XTERM);
4214 if (ckWARN(WARN_OCTAL)) {
4215 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4216 if (*d != '0' && isDIGIT(*d))
4217 yywarn("umask: argument is missing initial 0");
4222 LOP(OP_UNSHIFT,XTERM);
4225 if (PL_expect != XSTATE)
4226 yyerror("\"use\" not allowed in expression");
4229 s = force_version(s);
4230 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4231 PL_nextval[PL_nexttoke].opval = Nullop;
4236 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4237 s = force_version(s);
4250 yylval.ival = PL_curcop->cop_line;
4254 PL_hints |= HINT_BLOCK_SCOPE;
4261 LOP(OP_WAITPID,XTERM);
4269 static char ctl_l[2];
4271 if (ctl_l[0] == '\0')
4272 ctl_l[0] = toCTRL('L');
4273 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4276 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4281 if (PL_expect == XOPERATOR)
4287 yylval.ival = OP_XOR;
4292 TERM(sublex_start());
4298 keyword(register char *d, I32 len)
4303 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4304 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4305 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4306 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4307 if (strEQ(d,"__END__")) return KEY___END__;
4311 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4316 if (strEQ(d,"and")) return -KEY_and;
4317 if (strEQ(d,"abs")) return -KEY_abs;
4320 if (strEQ(d,"alarm")) return -KEY_alarm;
4321 if (strEQ(d,"atan2")) return -KEY_atan2;
4324 if (strEQ(d,"accept")) return -KEY_accept;
4329 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4332 if (strEQ(d,"bless")) return -KEY_bless;
4333 if (strEQ(d,"bind")) return -KEY_bind;
4334 if (strEQ(d,"binmode")) return -KEY_binmode;
4337 if (strEQ(d,"CORE")) return -KEY_CORE;
4342 if (strEQ(d,"cmp")) return -KEY_cmp;
4343 if (strEQ(d,"chr")) return -KEY_chr;
4344 if (strEQ(d,"cos")) return -KEY_cos;
4347 if (strEQ(d,"chop")) return KEY_chop;
4350 if (strEQ(d,"close")) return -KEY_close;
4351 if (strEQ(d,"chdir")) return -KEY_chdir;
4352 if (strEQ(d,"chomp")) return KEY_chomp;
4353 if (strEQ(d,"chmod")) return -KEY_chmod;
4354 if (strEQ(d,"chown")) return -KEY_chown;
4355 if (strEQ(d,"crypt")) return -KEY_crypt;
4358 if (strEQ(d,"chroot")) return -KEY_chroot;
4359 if (strEQ(d,"caller")) return -KEY_caller;
4362 if (strEQ(d,"connect")) return -KEY_connect;
4365 if (strEQ(d,"closedir")) return -KEY_closedir;
4366 if (strEQ(d,"continue")) return -KEY_continue;
4371 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4376 if (strEQ(d,"do")) return KEY_do;
4379 if (strEQ(d,"die")) return -KEY_die;
4382 if (strEQ(d,"dump")) return -KEY_dump;
4385 if (strEQ(d,"delete")) return KEY_delete;
4388 if (strEQ(d,"defined")) return KEY_defined;
4389 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4392 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4397 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4398 if (strEQ(d,"END")) return KEY_END;
4403 if (strEQ(d,"eq")) return -KEY_eq;
4406 if (strEQ(d,"eof")) return -KEY_eof;
4407 if (strEQ(d,"exp")) return -KEY_exp;
4410 if (strEQ(d,"else")) return KEY_else;
4411 if (strEQ(d,"exit")) return -KEY_exit;
4412 if (strEQ(d,"eval")) return KEY_eval;
4413 if (strEQ(d,"exec")) return -KEY_exec;
4414 if (strEQ(d,"each")) return KEY_each;
4417 if (strEQ(d,"elsif")) return KEY_elsif;
4420 if (strEQ(d,"exists")) return KEY_exists;
4421 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4424 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4425 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4428 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4431 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4432 if (strEQ(d,"endservent")) return -KEY_endservent;
4435 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4442 if (strEQ(d,"for")) return KEY_for;
4445 if (strEQ(d,"fork")) return -KEY_fork;
4448 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4449 if (strEQ(d,"flock")) return -KEY_flock;
4452 if (strEQ(d,"format")) return KEY_format;
4453 if (strEQ(d,"fileno")) return -KEY_fileno;
4456 if (strEQ(d,"foreach")) return KEY_foreach;
4459 if (strEQ(d,"formline")) return -KEY_formline;
4465 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4466 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4470 if (strnEQ(d,"get",3)) {
4475 if (strEQ(d,"ppid")) return -KEY_getppid;
4476 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4479 if (strEQ(d,"pwent")) return -KEY_getpwent;
4480 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4481 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4484 if (strEQ(d,"peername")) return -KEY_getpeername;
4485 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4486 if (strEQ(d,"priority")) return -KEY_getpriority;
4489 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4492 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4496 else if (*d == 'h') {
4497 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4498 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4499 if (strEQ(d,"hostent")) return -KEY_gethostent;
4501 else if (*d == 'n') {
4502 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4503 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4504 if (strEQ(d,"netent")) return -KEY_getnetent;
4506 else if (*d == 's') {
4507 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4508 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4509 if (strEQ(d,"servent")) return -KEY_getservent;
4510 if (strEQ(d,"sockname")) return -KEY_getsockname;
4511 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4513 else if (*d == 'g') {
4514 if (strEQ(d,"grent")) return -KEY_getgrent;
4515 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4516 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4518 else if (*d == 'l') {
4519 if (strEQ(d,"login")) return -KEY_getlogin;
4521 else if (strEQ(d,"c")) return -KEY_getc;
4526 if (strEQ(d,"gt")) return -KEY_gt;
4527 if (strEQ(d,"ge")) return -KEY_ge;
4530 if (strEQ(d,"grep")) return KEY_grep;
4531 if (strEQ(d,"goto")) return KEY_goto;
4532 if (strEQ(d,"glob")) return KEY_glob;
4535 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4540 if (strEQ(d,"hex")) return -KEY_hex;
4543 if (strEQ(d,"INIT")) return KEY_INIT;
4548 if (strEQ(d,"if")) return KEY_if;
4551 if (strEQ(d,"int")) return -KEY_int;
4554 if (strEQ(d,"index")) return -KEY_index;
4555 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4560 if (strEQ(d,"join")) return -KEY_join;
4564 if (strEQ(d,"keys")) return KEY_keys;
4565 if (strEQ(d,"kill")) return -KEY_kill;
4570 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4571 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4577 if (strEQ(d,"lt")) return -KEY_lt;
4578 if (strEQ(d,"le")) return -KEY_le;
4579 if (strEQ(d,"lc")) return -KEY_lc;
4582 if (strEQ(d,"log")) return -KEY_log;
4585 if (strEQ(d,"last")) return KEY_last;
4586 if (strEQ(d,"link")) return -KEY_link;
4587 if (strEQ(d,"lock")) return -KEY_lock;
4590 if (strEQ(d,"local")) return KEY_local;
4591 if (strEQ(d,"lstat")) return -KEY_lstat;
4594 if (strEQ(d,"length")) return -KEY_length;
4595 if (strEQ(d,"listen")) return -KEY_listen;
4598 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4601 if (strEQ(d,"localtime")) return -KEY_localtime;
4607 case 1: return KEY_m;
4609 if (strEQ(d,"my")) return KEY_my;
4612 if (strEQ(d,"map")) return KEY_map;
4615 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4618 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4619 if (strEQ(d,"msgget")) return -KEY_msgget;
4620 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4621 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4626 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4629 if (strEQ(d,"next")) return KEY_next;
4630 if (strEQ(d,"ne")) return -KEY_ne;
4631 if (strEQ(d,"not")) return -KEY_not;
4632 if (strEQ(d,"no")) return KEY_no;
4637 if (strEQ(d,"or")) return -KEY_or;
4640 if (strEQ(d,"ord")) return -KEY_ord;
4641 if (strEQ(d,"oct")) return -KEY_oct;
4642 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4646 if (strEQ(d,"open")) return -KEY_open;
4649 if (strEQ(d,"opendir")) return -KEY_opendir;
4656 if (strEQ(d,"pop")) return KEY_pop;
4657 if (strEQ(d,"pos")) return KEY_pos;
4660 if (strEQ(d,"push")) return KEY_push;
4661 if (strEQ(d,"pack")) return -KEY_pack;
4662 if (strEQ(d,"pipe")) return -KEY_pipe;
4665 if (strEQ(d,"print")) return KEY_print;
4668 if (strEQ(d,"printf")) return KEY_printf;
4671 if (strEQ(d,"package")) return KEY_package;
4674 if (strEQ(d,"prototype")) return KEY_prototype;
4679 if (strEQ(d,"q")) return KEY_q;
4680 if (strEQ(d,"qr")) return KEY_qr;
4681 if (strEQ(d,"qq")) return KEY_qq;
4682 if (strEQ(d,"qw")) return KEY_qw;
4683 if (strEQ(d,"qx")) return KEY_qx;
4685 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4690 if (strEQ(d,"ref")) return -KEY_ref;
4693 if (strEQ(d,"read")) return -KEY_read;
4694 if (strEQ(d,"rand")) return -KEY_rand;
4695 if (strEQ(d,"recv")) return -KEY_recv;
4696 if (strEQ(d,"redo")) return KEY_redo;
4699 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4700 if (strEQ(d,"reset")) return -KEY_reset;
4703 if (strEQ(d,"return")) return KEY_return;
4704 if (strEQ(d,"rename")) return -KEY_rename;
4705 if (strEQ(d,"rindex")) return -KEY_rindex;
4708 if (strEQ(d,"require")) return -KEY_require;
4709 if (strEQ(d,"reverse")) return -KEY_reverse;
4710 if (strEQ(d,"readdir")) return -KEY_readdir;
4713 if (strEQ(d,"readlink")) return -KEY_readlink;
4714 if (strEQ(d,"readline")) return -KEY_readline;
4715 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4718 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4724 case 0: return KEY_s;
4726 if (strEQ(d,"scalar")) return KEY_scalar;
4731 if (strEQ(d,"seek")) return -KEY_seek;
4732 if (strEQ(d,"send")) return -KEY_send;
4735 if (strEQ(d,"semop")) return -KEY_semop;
4738 if (strEQ(d,"select")) return -KEY_select;
4739 if (strEQ(d,"semctl")) return -KEY_semctl;
4740 if (strEQ(d,"semget")) return -KEY_semget;
4743 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4744 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4747 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4748 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4751 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4754 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4755 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4756 if (strEQ(d,"setservent")) return -KEY_setservent;
4759 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4760 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4767 if (strEQ(d,"shift")) return KEY_shift;
4770 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4771 if (strEQ(d,"shmget")) return -KEY_shmget;
4774 if (strEQ(d,"shmread")) return -KEY_shmread;
4777 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4778 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4783 if (strEQ(d,"sin")) return -KEY_sin;
4786 if (strEQ(d,"sleep")) return -KEY_sleep;
4789 if (strEQ(d,"sort")) return KEY_sort;
4790 if (strEQ(d,"socket")) return -KEY_socket;
4791 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4794 if (strEQ(d,"split")) return KEY_split;
4795 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4796 if (strEQ(d,"splice")) return KEY_splice;
4799 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4802 if (strEQ(d,"srand")) return -KEY_srand;
4805 if (strEQ(d,"stat")) return -KEY_stat;
4806 if (strEQ(d,"study")) return KEY_study;
4809 if (strEQ(d,"substr")) return -KEY_substr;
4810 if (strEQ(d,"sub")) return KEY_sub;
4815 if (strEQ(d,"system")) return -KEY_system;
4818 if (strEQ(d,"symlink")) return -KEY_symlink;
4819 if (strEQ(d,"syscall")) return -KEY_syscall;
4820 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4821 if (strEQ(d,"sysread")) return -KEY_sysread;
4822 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4825 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4834 if (strEQ(d,"tr")) return KEY_tr;
4837 if (strEQ(d,"tie")) return KEY_tie;
4840 if (strEQ(d,"tell")) return -KEY_tell;
4841 if (strEQ(d,"tied")) return KEY_tied;
4842 if (strEQ(d,"time")) return -KEY_time;
4845 if (strEQ(d,"times")) return -KEY_times;
4848 if (strEQ(d,"telldir")) return -KEY_telldir;
4851 if (strEQ(d,"truncate")) return -KEY_truncate;
4858 if (strEQ(d,"uc")) return -KEY_uc;
4861 if (strEQ(d,"use")) return KEY_use;
4864 if (strEQ(d,"undef")) return KEY_undef;
4865 if (strEQ(d,"until")) return KEY_until;
4866 if (strEQ(d,"untie")) return KEY_untie;
4867 if (strEQ(d,"utime")) return -KEY_utime;
4868 if (strEQ(d,"umask")) return -KEY_umask;
4871 if (strEQ(d,"unless")) return KEY_unless;
4872 if (strEQ(d,"unpack")) return -KEY_unpack;
4873 if (strEQ(d,"unlink")) return -KEY_unlink;
4876 if (strEQ(d,"unshift")) return KEY_unshift;
4877 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4882 if (strEQ(d,"values")) return -KEY_values;
4883 if (strEQ(d,"vec")) return -KEY_vec;
4888 if (strEQ(d,"warn")) return -KEY_warn;
4889 if (strEQ(d,"wait")) return -KEY_wait;
4892 if (strEQ(d,"while")) return KEY_while;
4893 if (strEQ(d,"write")) return -KEY_write;
4896 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4899 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4904 if (len == 1) return -KEY_x;
4905 if (strEQ(d,"xor")) return -KEY_xor;
4908 if (len == 1) return KEY_y;
4917 checkcomma(register char *s, char *name, char *what)
4921 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4922 dTHR; /* only for ckWARN */
4923 if (ckWARN(WARN_SYNTAX)) {
4925 for (w = s+2; *w && level; w++) {
4932 for (; *w && isSPACE(*w); w++) ;
4933 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4934 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4937 while (s < PL_bufend && isSPACE(*s))
4941 while (s < PL_bufend && isSPACE(*s))
4943 if (isIDFIRST_lazy(s)) {
4945 while (isALNUM_lazy(s))
4947 while (s < PL_bufend && isSPACE(*s))
4952 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4956 croak("No comma allowed after %s", what);
4962 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4965 HV *table = GvHV(PL_hintgv); /* ^H */
4968 bool oldcatch = CATCH_GET;
4973 yyerror("%^H is not defined");
4976 cvp = hv_fetch(table, key, strlen(key), FALSE);
4977 if (!cvp || !SvOK(*cvp)) {
4979 sprintf(buf,"$^H{%s} is not defined", key);
4983 sv_2mortal(sv); /* Parent created it permanently */
4986 pv = sv_2mortal(newSVpv(s, len));
4988 typesv = sv_2mortal(newSVpv(type, 0));
4990 typesv = &PL_sv_undef;
4992 Zero(&myop, 1, BINOP);
4993 myop.op_last = (OP *) &myop;
4994 myop.op_next = Nullop;
4995 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4997 PUSHSTACKi(PERLSI_OVERLOAD);
5000 PL_op = (OP *) &myop;
5001 if (PERLDB_SUB && PL_curstash != PL_debstash)
5002 PL_op->op_private |= OPpENTERSUB_DB;
5013 if (PL_op = pp_entersub(ARGS))
5020 CATCH_SET(oldcatch);
5025 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5028 return SvREFCNT_inc(res);
5032 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5034 register char *d = dest;
5035 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5038 croak(ident_too_long);
5039 if (isALNUM(*s)) /* UTF handled below */
5041 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5046 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5050 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5051 char *t = s + UTF8SKIP(s);
5052 while (*t & 0x80 && is_utf8_mark((U8*)t))
5054 if (d + (t - s) > e)
5055 croak(ident_too_long);
5056 Copy(s, d, t - s, char);
5069 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5076 if (PL_lex_brackets == 0)
5077 PL_lex_fakebrack = 0;
5081 e = d + destlen - 3; /* two-character token, ending NUL */
5083 while (isDIGIT(*s)) {
5085 croak(ident_too_long);
5092 croak(ident_too_long);
5093 if (isALNUM(*s)) /* UTF handled below */
5095 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5100 else if (*s == ':' && s[1] == ':') {
5104 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5105 char *t = s + UTF8SKIP(s);
5106 while (*t & 0x80 && is_utf8_mark((U8*)t))
5108 if (d + (t - s) > e)
5109 croak(ident_too_long);
5110 Copy(s, d, t - s, char);
5121 if (PL_lex_state != LEX_NORMAL)
5122 PL_lex_state = LEX_INTERPENDMAYBE;
5125 if (*s == '$' && s[1] &&
5126 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5139 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5144 if (isSPACE(s[-1])) {
5147 if (ch != ' ' && ch != '\t') {
5153 if (isIDFIRST_lazy(d)) {
5157 while (e < send && isALNUM_lazy(e) || *e == ':') {
5159 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5162 Copy(s, d, e - s, char);
5167 while (isALNUM(*s) || *s == ':')
5171 while (s < send && (*s == ' ' || *s == '\t')) s++;
5172 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5173 dTHR; /* only for ckWARN */
5174 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5175 char *brack = *s == '[' ? "[...]" : "{...}";
5176 warner(WARN_AMBIGUOUS,
5177 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5178 funny, dest, brack, funny, dest, brack);
5180 PL_lex_fakebrack = PL_lex_brackets+1;
5182 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5188 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5189 PL_lex_state = LEX_INTERPEND;
5192 if (PL_lex_state == LEX_NORMAL) {
5193 dTHR; /* only for ckWARN */
5194 if (ckWARN(WARN_AMBIGUOUS) &&
5195 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5197 warner(WARN_AMBIGUOUS,
5198 "Ambiguous use of %c{%s} resolved to %c%s",
5199 funny, dest, funny, dest);
5204 s = bracket; /* let the parser handle it */
5208 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5209 PL_lex_state = LEX_INTERPEND;
5213 void pmflag(U16 *pmfl, int ch)
5218 *pmfl |= PMf_GLOBAL;
5220 *pmfl |= PMf_CONTINUE;
5224 *pmfl |= PMf_MULTILINE;
5226 *pmfl |= PMf_SINGLELINE;
5228 *pmfl |= PMf_EXTENDED;
5232 scan_pat(char *start, I32 type)
5237 s = scan_str(start);
5240 SvREFCNT_dec(PL_lex_stuff);
5241 PL_lex_stuff = Nullsv;
5242 croak("Search pattern not terminated");
5245 pm = (PMOP*)newPMOP(type, 0);
5246 if (PL_multi_open == '?')
5247 pm->op_pmflags |= PMf_ONCE;
5249 while (*s && strchr("iomsx", *s))
5250 pmflag(&pm->op_pmflags,*s++);
5253 while (*s && strchr("iogcmsx", *s))
5254 pmflag(&pm->op_pmflags,*s++);
5256 pm->op_pmpermflags = pm->op_pmflags;
5258 PL_lex_op = (OP*)pm;
5259 yylval.ival = OP_MATCH;
5264 scan_subst(char *start)
5271 yylval.ival = OP_NULL;
5273 s = scan_str(start);
5277 SvREFCNT_dec(PL_lex_stuff);
5278 PL_lex_stuff = Nullsv;
5279 croak("Substitution pattern not terminated");
5282 if (s[-1] == PL_multi_open)
5285 first_start = PL_multi_start;
5289 SvREFCNT_dec(PL_lex_stuff);
5290 PL_lex_stuff = Nullsv;
5292 SvREFCNT_dec(PL_lex_repl);
5293 PL_lex_repl = Nullsv;
5294 croak("Substitution replacement not terminated");
5296 PL_multi_start = first_start; /* so whole substitution is taken together */
5298 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5304 else if (strchr("iogcmsx", *s))
5305 pmflag(&pm->op_pmflags,*s++);
5312 pm->op_pmflags |= PMf_EVAL;
5313 repl = newSVpv("",0);
5315 sv_catpv(repl, es ? "eval " : "do ");
5316 sv_catpvn(repl, "{ ", 2);
5317 sv_catsv(repl, PL_lex_repl);
5318 sv_catpvn(repl, " };", 2);
5319 SvCOMPILED_on(repl);
5320 SvREFCNT_dec(PL_lex_repl);
5324 pm->op_pmpermflags = pm->op_pmflags;
5325 PL_lex_op = (OP*)pm;
5326 yylval.ival = OP_SUBST;
5331 scan_trans(char *start)
5342 yylval.ival = OP_NULL;
5344 s = scan_str(start);
5347 SvREFCNT_dec(PL_lex_stuff);
5348 PL_lex_stuff = Nullsv;
5349 croak("Transliteration pattern not terminated");
5351 if (s[-1] == PL_multi_open)
5357 SvREFCNT_dec(PL_lex_stuff);
5358 PL_lex_stuff = Nullsv;
5360 SvREFCNT_dec(PL_lex_repl);
5361 PL_lex_repl = Nullsv;
5362 croak("Transliteration replacement not terminated");
5366 o = newSVOP(OP_TRANS, 0, 0);
5367 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5370 New(803,tbl,256,short);
5371 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5375 complement = del = squash = 0;
5376 while (strchr("cdsCU", *s)) {
5378 complement = OPpTRANS_COMPLEMENT;
5380 del = OPpTRANS_DELETE;
5382 squash = OPpTRANS_SQUASH;
5387 utf8 &= ~OPpTRANS_FROM_UTF;
5389 utf8 |= OPpTRANS_FROM_UTF;
5393 utf8 &= ~OPpTRANS_TO_UTF;
5395 utf8 |= OPpTRANS_TO_UTF;
5398 croak("Too many /C and /U options");
5403 o->op_private = del|squash|complement|utf8;
5406 yylval.ival = OP_TRANS;
5411 scan_heredoc(register char *s)
5415 I32 op_type = OP_SCALAR;
5422 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5426 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5429 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5430 if (*peek && strchr("`'\"",*peek)) {
5433 s = delimcpy(d, e, s, PL_bufend, term, &len);
5443 if (!isALNUM_lazy(s))
5444 deprecate("bare << to mean <<\"\"");
5445 for (; isALNUM_lazy(s); s++) {
5450 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5451 croak("Delimiter for here document is too long");
5454 len = d - PL_tokenbuf;
5455 #ifndef PERL_STRICT_CR
5456 d = strchr(s, '\r');
5460 while (s < PL_bufend) {
5466 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5475 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5480 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5481 herewas = newSVpv(s,PL_bufend-s);
5483 s--, herewas = newSVpv(s,d-s);
5484 s += SvCUR(herewas);
5486 tmpstr = NEWSV(87,79);
5487 sv_upgrade(tmpstr, SVt_PVIV);
5492 else if (term == '`') {
5493 op_type = OP_BACKTICK;
5494 SvIVX(tmpstr) = '\\';
5498 PL_multi_start = PL_curcop->cop_line;
5499 PL_multi_open = PL_multi_close = '<';
5500 term = *PL_tokenbuf;
5503 while (s < PL_bufend &&
5504 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5506 PL_curcop->cop_line++;
5508 if (s >= PL_bufend) {
5509 PL_curcop->cop_line = PL_multi_start;
5510 missingterm(PL_tokenbuf);
5512 sv_setpvn(tmpstr,d+1,s-d);
5514 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5516 sv_catpvn(herewas,s,PL_bufend-s);
5517 sv_setsv(PL_linestr,herewas);
5518 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5519 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5522 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5523 while (s >= PL_bufend) { /* multiple line string? */
5525 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5526 PL_curcop->cop_line = PL_multi_start;
5527 missingterm(PL_tokenbuf);
5529 PL_curcop->cop_line++;
5530 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5531 #ifndef PERL_STRICT_CR
5532 if (PL_bufend - PL_linestart >= 2) {
5533 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5534 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5536 PL_bufend[-2] = '\n';
5538 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5540 else if (PL_bufend[-1] == '\r')
5541 PL_bufend[-1] = '\n';
5543 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5544 PL_bufend[-1] = '\n';
5546 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5547 SV *sv = NEWSV(88,0);
5549 sv_upgrade(sv, SVt_PVMG);
5550 sv_setsv(sv,PL_linestr);
5551 av_store(GvAV(PL_curcop->cop_filegv),
5552 (I32)PL_curcop->cop_line,sv);
5554 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5557 sv_catsv(PL_linestr,herewas);
5558 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5562 sv_catsv(tmpstr,PL_linestr);
5565 PL_multi_end = PL_curcop->cop_line;
5567 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5568 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5569 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5571 SvREFCNT_dec(herewas);
5572 PL_lex_stuff = tmpstr;
5573 yylval.ival = op_type;
5578 takes: current position in input buffer
5579 returns: new position in input buffer
5580 side-effects: yylval and lex_op are set.
5585 <FH> read from filehandle
5586 <pkg::FH> read from package qualified filehandle
5587 <pkg'FH> read from package qualified filehandle
5588 <$fh> read from filehandle in $fh
5594 scan_inputsymbol(char *start)
5596 register char *s = start; /* current position in buffer */
5601 d = PL_tokenbuf; /* start of temp holding space */
5602 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5603 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5605 /* die if we didn't have space for the contents of the <>,
5609 if (len >= sizeof PL_tokenbuf)
5610 croak("Excessively long <> operator");
5612 croak("Unterminated <> operator");
5617 Remember, only scalar variables are interpreted as filehandles by
5618 this code. Anything more complex (e.g., <$fh{$num}>) will be
5619 treated as a glob() call.
5620 This code makes use of the fact that except for the $ at the front,
5621 a scalar variable and a filehandle look the same.
5623 if (*d == '$' && d[1]) d++;
5625 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5626 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5629 /* If we've tried to read what we allow filehandles to look like, and
5630 there's still text left, then it must be a glob() and not a getline.
5631 Use scan_str to pull out the stuff between the <> and treat it
5632 as nothing more than a string.
5635 if (d - PL_tokenbuf != len) {
5636 yylval.ival = OP_GLOB;
5638 s = scan_str(start);
5640 croak("Glob not terminated");
5644 /* we're in a filehandle read situation */
5647 /* turn <> into <ARGV> */
5649 (void)strcpy(d,"ARGV");
5651 /* if <$fh>, create the ops to turn the variable into a
5657 /* try to find it in the pad for this block, otherwise find
5658 add symbol table ops
5660 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5661 OP *o = newOP(OP_PADSV, 0);
5663 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5666 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5667 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5668 newUNOP(OP_RV2SV, 0,
5669 newGVOP(OP_GV, 0, gv)));
5671 PL_lex_op->op_flags |= OPf_SPECIAL;
5672 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5673 yylval.ival = OP_NULL;
5676 /* If it's none of the above, it must be a literal filehandle
5677 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5679 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5680 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5681 yylval.ival = OP_NULL;
5690 takes: start position in buffer
5691 returns: position to continue reading from buffer
5692 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5693 updates the read buffer.
5695 This subroutine pulls a string out of the input. It is called for:
5696 q single quotes q(literal text)
5697 ' single quotes 'literal text'
5698 qq double quotes qq(interpolate $here please)
5699 " double quotes "interpolate $here please"
5700 qx backticks qx(/bin/ls -l)
5701 ` backticks `/bin/ls -l`
5702 qw quote words @EXPORT_OK = qw( func() $spam )
5703 m// regexp match m/this/
5704 s/// regexp substitute s/this/that/
5705 tr/// string transliterate tr/this/that/
5706 y/// string transliterate y/this/that/
5707 ($*@) sub prototypes sub foo ($)
5708 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5710 In most of these cases (all but <>, patterns and transliterate)
5711 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5712 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5713 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5716 It skips whitespace before the string starts, and treats the first
5717 character as the delimiter. If the delimiter is one of ([{< then
5718 the corresponding "close" character )]}> is used as the closing
5719 delimiter. It allows quoting of delimiters, and if the string has
5720 balanced delimiters ([{<>}]) it allows nesting.
5722 The lexer always reads these strings into lex_stuff, except in the
5723 case of the operators which take *two* arguments (s/// and tr///)
5724 when it checks to see if lex_stuff is full (presumably with the 1st
5725 arg to s or tr) and if so puts the string into lex_repl.
5730 scan_str(char *start)
5733 SV *sv; /* scalar value: string */
5734 char *tmps; /* temp string, used for delimiter matching */
5735 register char *s = start; /* current position in the buffer */
5736 register char term; /* terminating character */
5737 register char *to; /* current position in the sv's data */
5738 I32 brackets = 1; /* bracket nesting level */
5740 /* skip space before the delimiter */
5744 /* mark where we are, in case we need to report errors */
5747 /* after skipping whitespace, the next character is the terminator */
5749 /* mark where we are */
5750 PL_multi_start = PL_curcop->cop_line;
5751 PL_multi_open = term;
5753 /* find corresponding closing delimiter */
5754 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5756 PL_multi_close = term;
5758 /* create a new SV to hold the contents. 87 is leak category, I'm
5759 assuming. 79 is the SV's initial length. What a random number. */
5761 sv_upgrade(sv, SVt_PVIV);
5763 (void)SvPOK_only(sv); /* validate pointer */
5765 /* move past delimiter and try to read a complete string */
5768 /* extend sv if need be */
5769 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5770 /* set 'to' to the next character in the sv's string */
5771 to = SvPVX(sv)+SvCUR(sv);
5773 /* if open delimiter is the close delimiter read unbridle */
5774 if (PL_multi_open == PL_multi_close) {
5775 for (; s < PL_bufend; s++,to++) {
5776 /* embedded newlines increment the current line number */
5777 if (*s == '\n' && !PL_rsfp)
5778 PL_curcop->cop_line++;
5779 /* handle quoted delimiters */
5780 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5783 /* any other quotes are simply copied straight through */
5787 /* terminate when run out of buffer (the for() condition), or
5788 have found the terminator */
5789 else if (*s == term)
5795 /* if the terminator isn't the same as the start character (e.g.,
5796 matched brackets), we have to allow more in the quoting, and
5797 be prepared for nested brackets.
5800 /* read until we run out of string, or we find the terminator */
5801 for (; s < PL_bufend; s++,to++) {
5802 /* embedded newlines increment the line count */
5803 if (*s == '\n' && !PL_rsfp)
5804 PL_curcop->cop_line++;
5805 /* backslashes can escape the open or closing characters */
5806 if (*s == '\\' && s+1 < PL_bufend) {
5807 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5812 /* allow nested opens and closes */
5813 else if (*s == PL_multi_close && --brackets <= 0)
5815 else if (*s == PL_multi_open)
5820 /* terminate the copied string and update the sv's end-of-string */
5822 SvCUR_set(sv, to - SvPVX(sv));
5825 * this next chunk reads more into the buffer if we're not done yet
5828 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5830 #ifndef PERL_STRICT_CR
5831 if (to - SvPVX(sv) >= 2) {
5832 if ((to[-2] == '\r' && to[-1] == '\n') ||
5833 (to[-2] == '\n' && to[-1] == '\r'))
5837 SvCUR_set(sv, to - SvPVX(sv));
5839 else if (to[-1] == '\r')
5842 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5846 /* if we're out of file, or a read fails, bail and reset the current
5847 line marker so we can report where the unterminated string began
5850 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5852 PL_curcop->cop_line = PL_multi_start;
5855 /* we read a line, so increment our line counter */
5856 PL_curcop->cop_line++;
5858 /* update debugger info */
5859 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5860 SV *sv = NEWSV(88,0);
5862 sv_upgrade(sv, SVt_PVMG);
5863 sv_setsv(sv,PL_linestr);
5864 av_store(GvAV(PL_curcop->cop_filegv),
5865 (I32)PL_curcop->cop_line, sv);
5868 /* having changed the buffer, we must update PL_bufend */
5869 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5872 /* at this point, we have successfully read the delimited string */
5874 PL_multi_end = PL_curcop->cop_line;
5877 /* if we allocated too much space, give some back */
5878 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5879 SvLEN_set(sv, SvCUR(sv) + 1);
5880 Renew(SvPVX(sv), SvLEN(sv), char);
5883 /* decide whether this is the first or second quoted string we've read
5896 takes: pointer to position in buffer
5897 returns: pointer to new position in buffer
5898 side-effects: builds ops for the constant in yylval.op
5900 Read a number in any of the formats that Perl accepts:
5902 0(x[0-7A-F]+)|([0-7]+)|(b[01])
5903 [\d_]+(\.[\d_]*)?[Ee](\d+)
5905 Underbars (_) are allowed in decimal numbers. If -w is on,
5906 underbars before a decimal point must be at three digit intervals.
5908 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5911 If it reads a number without a decimal point or an exponent, it will
5912 try converting the number to an integer and see if it can do so
5913 without loss of precision.
5917 scan_num(char *start)
5919 register char *s = start; /* current position in buffer */
5920 register char *d; /* destination in temp buffer */
5921 register char *e; /* end of temp buffer */
5922 I32 tryiv; /* used to see if it can be an int */
5923 double value; /* number read, as a double */
5924 SV *sv; /* place to put the converted number */
5925 I32 floatit; /* boolean: int or float? */
5926 char *lastub = 0; /* position of last underbar */
5927 static char number_too_long[] = "Number too long";
5929 /* We use the first character to decide what type of number this is */
5933 croak("panic: scan_num");
5935 /* if it starts with a 0, it could be an octal number, a decimal in
5936 0.13 disguise, or a hexadecimal number, or a binary number.
5941 u holds the "number so far"
5942 shift the power of 2 of the base
5943 (hex == 4, octal == 3, binary == 1)
5944 overflowed was the number more than we can hold?
5946 Shift is used when we add a digit. It also serves as an "are
5947 we in octal/hex/binary?" indicator to disallow hex characters
5952 bool overflowed = FALSE;
5958 } else if (s[1] == 'b') {
5962 /* check for a decimal in disguise */
5963 else if (s[1] == '.')
5965 /* so it must be octal */
5970 /* read the rest of the number */
5972 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5976 /* if we don't mention it, we're done */
5985 /* 8 and 9 are not octal */
5988 yyerror("Illegal octal digit");
5991 yyerror("Illegal binary digit");
5995 case '2': case '3': case '4':
5996 case '5': case '6': case '7':
5998 yyerror("Illegal binary digit");
6002 b = *s++ & 15; /* ASCII digit -> value of digit */
6006 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6007 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6008 /* make sure they said 0x */
6013 /* Prepare to put the digit we have onto the end
6014 of the number so far. We check for overflows.
6018 n = u << shift; /* make room for the digit */
6019 if (!overflowed && (n >> shift) != u
6020 && !(PL_hints & HINT_NEW_BINARY)) {
6021 warn("Integer overflow in %s number",
6022 (shift == 4) ? "hex"
6023 : ((shift == 3) ? "octal" : "binary"));
6026 u = n | b; /* add the digit to the end */
6031 /* if we get here, we had success: make a scalar value from
6037 if ( PL_hints & HINT_NEW_BINARY)
6038 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6043 handle decimal numbers.
6044 we're also sent here when we read a 0 as the first digit
6046 case '1': case '2': case '3': case '4': case '5':
6047 case '6': case '7': case '8': case '9': case '.':
6050 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6053 /* read next group of digits and _ and copy into d */
6054 while (isDIGIT(*s) || *s == '_') {
6055 /* skip underscores, checking for misplaced ones
6059 dTHR; /* only for ckWARN */
6060 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6061 warner(WARN_SYNTAX, "Misplaced _ in number");
6065 /* check for end of fixed-length buffer */
6067 croak(number_too_long);
6068 /* if we're ok, copy the character */
6073 /* final misplaced underbar check */
6074 if (lastub && s - lastub != 3) {
6076 if (ckWARN(WARN_SYNTAX))
6077 warner(WARN_SYNTAX, "Misplaced _ in number");
6080 /* read a decimal portion if there is one. avoid
6081 3..5 being interpreted as the number 3. followed
6084 if (*s == '.' && s[1] != '.') {
6088 /* copy, ignoring underbars, until we run out of
6089 digits. Note: no misplaced underbar checks!
6091 for (; isDIGIT(*s) || *s == '_'; s++) {
6092 /* fixed length buffer check */
6094 croak(number_too_long);
6100 /* read exponent part, if present */
6101 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6105 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6106 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6108 /* allow positive or negative exponent */
6109 if (*s == '+' || *s == '-')
6112 /* read digits of exponent (no underbars :-) */
6113 while (isDIGIT(*s)) {
6115 croak(number_too_long);
6120 /* terminate the string */
6123 /* make an sv from the string */
6125 /* reset numeric locale in case we were earlier left in Swaziland */
6126 SET_NUMERIC_STANDARD();
6127 value = atof(PL_tokenbuf);
6130 See if we can make do with an integer value without loss of
6131 precision. We use I_V to cast to an int, because some
6132 compilers have issues. Then we try casting it back and see
6133 if it was the same. We only do this if we know we
6134 specifically read an integer.
6136 Note: if floatit is true, then we don't need to do the
6140 if (!floatit && (double)tryiv == value)
6141 sv_setiv(sv, tryiv);
6143 sv_setnv(sv, value);
6144 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6145 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6146 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6150 /* make the op for the constant and return */
6152 yylval.opval = newSVOP(OP_CONST, 0, sv);
6158 scan_formline(register char *s)
6163 SV *stuff = newSVpv("",0);
6164 bool needargs = FALSE;
6167 if (*s == '.' || *s == '}') {
6169 #ifdef PERL_STRICT_CR
6170 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6172 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6174 if (*t == '\n' || t == PL_bufend)
6177 if (PL_in_eval && !PL_rsfp) {
6178 eol = strchr(s,'\n');
6183 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6185 for (t = s; t < eol; t++) {
6186 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6188 goto enough; /* ~~ must be first line in formline */
6190 if (*t == '@' || *t == '^')
6193 sv_catpvn(stuff, s, eol-s);
6197 s = filter_gets(PL_linestr, PL_rsfp, 0);
6198 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6199 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6202 yyerror("Format not terminated");
6212 PL_lex_state = LEX_NORMAL;
6213 PL_nextval[PL_nexttoke].ival = 0;
6217 PL_lex_state = LEX_FORMLINE;
6218 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6220 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6224 SvREFCNT_dec(stuff);
6225 PL_lex_formbrack = 0;
6236 PL_cshlen = strlen(PL_cshname);
6241 start_subparse(I32 is_format, U32 flags)
6244 I32 oldsavestack_ix = PL_savestack_ix;
6245 CV* outsidecv = PL_compcv;
6249 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6251 save_I32(&PL_subline);
6252 save_item(PL_subname);
6254 SAVESPTR(PL_curpad);
6255 SAVESPTR(PL_comppad);
6256 SAVESPTR(PL_comppad_name);
6257 SAVESPTR(PL_compcv);
6258 SAVEI32(PL_comppad_name_fill);
6259 SAVEI32(PL_min_intro_pending);
6260 SAVEI32(PL_max_intro_pending);
6261 SAVEI32(PL_pad_reset_pending);
6263 PL_compcv = (CV*)NEWSV(1104,0);
6264 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6265 CvFLAGS(PL_compcv) |= flags;
6267 PL_comppad = newAV();
6268 av_push(PL_comppad, Nullsv);
6269 PL_curpad = AvARRAY(PL_comppad);
6270 PL_comppad_name = newAV();
6271 PL_comppad_name_fill = 0;
6272 PL_min_intro_pending = 0;
6274 PL_subline = PL_curcop->cop_line;
6276 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6277 PL_curpad[0] = (SV*)newAV();
6278 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6279 #endif /* USE_THREADS */
6281 comppadlist = newAV();
6282 AvREAL_off(comppadlist);
6283 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6284 av_store(comppadlist, 1, (SV*)PL_comppad);
6286 CvPADLIST(PL_compcv) = comppadlist;
6287 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6289 CvOWNER(PL_compcv) = 0;
6290 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6291 MUTEX_INIT(CvMUTEXP(PL_compcv));
6292 #endif /* USE_THREADS */
6294 return oldsavestack_ix;
6313 char *context = NULL;
6317 if (!yychar || (yychar == ';' && !PL_rsfp))
6319 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6320 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6321 while (isSPACE(*PL_oldoldbufptr))
6323 context = PL_oldoldbufptr;
6324 contlen = PL_bufptr - PL_oldoldbufptr;
6326 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6327 PL_oldbufptr != PL_bufptr) {
6328 while (isSPACE(*PL_oldbufptr))
6330 context = PL_oldbufptr;
6331 contlen = PL_bufptr - PL_oldbufptr;
6333 else if (yychar > 255)
6334 where = "next token ???";
6335 else if ((yychar & 127) == 127) {
6336 if (PL_lex_state == LEX_NORMAL ||
6337 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6338 where = "at end of line";
6339 else if (PL_lex_inpat)
6340 where = "within pattern";
6342 where = "within string";
6345 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6347 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6348 else if (isPRINT_LC(yychar))
6349 sv_catpvf(where_sv, "%c", yychar);
6351 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6352 where = SvPVX(where_sv);
6354 msg = sv_2mortal(newSVpv(s, 0));
6355 sv_catpvf(msg, " at %_ line %ld, ",
6356 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6358 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6360 sv_catpvf(msg, "%s\n", where);
6361 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6363 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6364 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6369 else if (PL_in_eval)
6370 sv_catsv(ERRSV, msg);
6372 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6373 if (++PL_error_count >= 10)
6374 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6376 PL_in_my_stash = Nullhv;