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 (*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 */
1097 /* \132 indicates an octal constant */
1098 case '0': case '1': case '2': case '3':
1099 case '4': case '5': case '6': case '7':
1100 *d++ = scan_oct(s, 3, &len);
1104 /* \x24 indicates a hex constant */
1108 char* e = strchr(s, '}');
1111 yyerror("Missing right brace on \\x{}");
1116 if (ckWARN(WARN_UTF8))
1118 "Use of \\x{} without utf8 declaration");
1120 /* note: utf always shorter than hex */
1121 d = (char*)uv_to_utf8((U8*)d,
1122 scan_hex(s + 1, e - s - 1, &len));
1127 UV uv = (UV)scan_hex(s, 2, &len);
1128 if (utf && PL_lex_inwhat == OP_TRANS &&
1129 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1131 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1134 if (uv >= 127 && UTF) {
1136 if (ckWARN(WARN_UTF8))
1138 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1147 /* \c is a control character */
1161 /* printf-style backslashes, formfeeds, newlines, etc */
1187 } /* end if (backslash) */
1190 } /* while loop to process each character */
1192 /* terminate the string and set up the sv */
1194 SvCUR_set(sv, d - SvPVX(sv));
1197 /* shrink the sv if we allocated more than we used */
1198 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1199 SvLEN_set(sv, SvCUR(sv) + 1);
1200 Renew(SvPVX(sv), SvLEN(sv), char);
1203 /* return the substring (via yylval) only if we parsed anything */
1204 if (s > PL_bufptr) {
1205 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1206 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1208 ( PL_lex_inwhat == OP_TRANS
1210 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1213 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1219 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1221 intuit_more(register char *s)
1223 if (PL_lex_brackets)
1225 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1227 if (*s != '{' && *s != '[')
1232 /* In a pattern, so maybe we have {n,m}. */
1249 /* On the other hand, maybe we have a character class */
1252 if (*s == ']' || *s == '^')
1255 int weight = 2; /* let's weigh the evidence */
1257 unsigned char un_char = 255, last_un_char;
1258 char *send = strchr(s,']');
1259 char tmpbuf[sizeof PL_tokenbuf * 4];
1261 if (!send) /* has to be an expression */
1264 Zero(seen,256,char);
1267 else if (isDIGIT(*s)) {
1269 if (isDIGIT(s[1]) && s[2] == ']')
1275 for (; s < send; s++) {
1276 last_un_char = un_char;
1277 un_char = (unsigned char)*s;
1282 weight -= seen[un_char] * 10;
1283 if (isALNUM_lazy(s+1)) {
1284 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1285 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1290 else if (*s == '$' && s[1] &&
1291 strchr("[#!%*<>()-=",s[1])) {
1292 if (/*{*/ strchr("])} =",s[2]))
1301 if (strchr("wds]",s[1]))
1303 else if (seen['\''] || seen['"'])
1305 else if (strchr("rnftbxcav",s[1]))
1307 else if (isDIGIT(s[1])) {
1309 while (s[1] && isDIGIT(s[1]))
1319 if (strchr("aA01! ",last_un_char))
1321 if (strchr("zZ79~",s[1]))
1323 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1324 weight -= 5; /* cope with negative subscript */
1327 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1328 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1333 if (keyword(tmpbuf, d - tmpbuf))
1336 if (un_char == last_un_char + 1)
1338 weight -= seen[un_char];
1343 if (weight >= 0) /* probably a character class */
1351 intuit_method(char *start, GV *gv)
1353 char *s = start + (*start == '$');
1354 char tmpbuf[sizeof PL_tokenbuf];
1362 if ((cv = GvCVu(gv))) {
1363 char *proto = SvPVX(cv);
1373 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1374 if (*start == '$') {
1375 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1380 return *s == '(' ? FUNCMETH : METHOD;
1382 if (!keyword(tmpbuf, len)) {
1383 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1388 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1389 if (indirgv && GvCVu(indirgv))
1391 /* filehandle or package name makes it a method */
1392 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1394 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1395 return 0; /* no assumptions -- "=>" quotes bearword */
1397 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1399 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1403 return *s == '(' ? FUNCMETH : METHOD;
1413 char *pdb = PerlEnv_getenv("PERL5DB");
1417 SETERRNO(0,SS$_NORMAL);
1418 return "BEGIN { require 'perl5db.pl' }";
1424 /* Encoded script support. filter_add() effectively inserts a
1425 * 'pre-processing' function into the current source input stream.
1426 * Note that the filter function only applies to the current source file
1427 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1429 * The datasv parameter (which may be NULL) can be used to pass
1430 * private data to this instance of the filter. The filter function
1431 * can recover the SV using the FILTER_DATA macro and use it to
1432 * store private buffers and state information.
1434 * The supplied datasv parameter is upgraded to a PVIO type
1435 * and the IoDIRP field is used to store the function pointer.
1436 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1437 * private use must be set using malloc'd pointers.
1439 static int filter_debug = 0;
1442 filter_add(filter_t funcp, SV *datasv)
1444 if (!funcp){ /* temporary handy debugging hack to be deleted */
1445 filter_debug = atoi((char*)datasv);
1448 if (!PL_rsfp_filters)
1449 PL_rsfp_filters = newAV();
1451 datasv = NEWSV(255,0);
1452 if (!SvUPGRADE(datasv, SVt_PVIO))
1453 die("Can't upgrade filter_add data to SVt_PVIO");
1454 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1456 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1457 av_unshift(PL_rsfp_filters, 1);
1458 av_store(PL_rsfp_filters, 0, datasv) ;
1463 /* Delete most recently added instance of this filter function. */
1465 filter_del(filter_t funcp)
1468 warn("filter_del func %p", funcp);
1469 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1471 /* if filter is on top of stack (usual case) just pop it off */
1472 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1473 sv_free(av_pop(PL_rsfp_filters));
1477 /* we need to search for the correct entry and clear it */
1478 die("filter_del can only delete in reverse order (currently)");
1482 /* Invoke the n'th filter function for the current rsfp. */
1484 filter_read(int idx, SV *buf_sv, int maxlen)
1487 /* 0 = read one text line */
1492 if (!PL_rsfp_filters)
1494 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1495 /* Provide a default input filter to make life easy. */
1496 /* Note that we append to the line. This is handy. */
1498 warn("filter_read %d: from rsfp\n", idx);
1502 int old_len = SvCUR(buf_sv) ;
1504 /* ensure buf_sv is large enough */
1505 SvGROW(buf_sv, old_len + maxlen) ;
1506 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1507 if (PerlIO_error(PL_rsfp))
1508 return -1; /* error */
1510 return 0 ; /* end of file */
1512 SvCUR_set(buf_sv, old_len + len) ;
1515 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1516 if (PerlIO_error(PL_rsfp))
1517 return -1; /* error */
1519 return 0 ; /* end of file */
1522 return SvCUR(buf_sv);
1524 /* Skip this filter slot if filter has been deleted */
1525 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1527 warn("filter_read %d: skipped (filter deleted)\n", idx);
1528 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1530 /* Get function pointer hidden within datasv */
1531 funcp = (filter_t)IoDIRP(datasv);
1533 warn("filter_read %d: via function %p (%s)\n",
1534 idx, funcp, SvPV(datasv,PL_na));
1535 /* Call function. The function is expected to */
1536 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1537 /* Return: <0:error, =0:eof, >0:not eof */
1538 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1542 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1545 if (!PL_rsfp_filters) {
1546 filter_add(win32_textfilter,NULL);
1549 if (PL_rsfp_filters) {
1552 SvCUR_set(sv, 0); /* start with empty line */
1553 if (FILTER_READ(0, sv, 0) > 0)
1554 return ( SvPVX(sv) ) ;
1559 return (sv_gets(sv, fp, append));
1564 static char* exp_name[] =
1565 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1571 Works out what to call the token just pulled out of the input
1572 stream. The yacc parser takes care of taking the ops we return and
1573 stitching them into a tree.
1579 if read an identifier
1580 if we're in a my declaration
1581 croak if they tried to say my($foo::bar)
1582 build the ops for a my() declaration
1583 if it's an access to a my() variable
1584 are we in a sort block?
1585 croak if my($a); $a <=> $b
1586 build ops for access to a my() variable
1587 if in a dq string, and they've said @foo and we can't find @foo
1589 build ops for a bareword
1590 if we already built the token before, use it.
1593 int yylex(PERL_YYLEX_PARAM_DECL)
1603 #ifdef USE_PURE_BISON
1604 yylval_pointer = lvalp;
1605 yychar_pointer = lcharp;
1608 /* check if there's an identifier for us to look at */
1609 if (PL_pending_ident) {
1610 /* pit holds the identifier we read and pending_ident is reset */
1611 char pit = PL_pending_ident;
1612 PL_pending_ident = 0;
1614 /* if we're in a my(), we can't allow dynamics here.
1615 $foo'bar has already been turned into $foo::bar, so
1616 just check for colons.
1618 if it's a legal name, the OP is a PADANY.
1621 if (strchr(PL_tokenbuf,':'))
1622 croak(PL_no_myglob,PL_tokenbuf);
1624 yylval.opval = newOP(OP_PADANY, 0);
1625 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1630 build the ops for accesses to a my() variable.
1632 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1633 then used in a comparison. This catches most, but not
1634 all cases. For instance, it catches
1635 sort { my($a); $a <=> $b }
1637 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1638 (although why you'd do that is anyone's guess).
1641 if (!strchr(PL_tokenbuf,':')) {
1643 /* Check for single character per-thread SVs */
1644 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1645 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1646 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1648 yylval.opval = newOP(OP_THREADSV, 0);
1649 yylval.opval->op_targ = tmp;
1652 #endif /* USE_THREADS */
1653 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1654 /* if it's a sort block and they're naming $a or $b */
1655 if (PL_last_lop_op == OP_SORT &&
1656 PL_tokenbuf[0] == '$' &&
1657 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1660 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1661 d < PL_bufend && *d != '\n';
1664 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1665 croak("Can't use \"my %s\" in sort comparison",
1671 yylval.opval = newOP(OP_PADANY, 0);
1672 yylval.opval->op_targ = tmp;
1678 Whine if they've said @foo in a doublequoted string,
1679 and @foo isn't a variable we can find in the symbol
1682 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1683 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1684 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1685 yyerror(form("In string, %s now must be written as \\%s",
1686 PL_tokenbuf, PL_tokenbuf));
1689 /* build ops for a bareword */
1690 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1691 yylval.opval->op_private = OPpCONST_ENTERED;
1692 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1693 ((PL_tokenbuf[0] == '$') ? SVt_PV
1694 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1699 /* no identifier pending identification */
1701 switch (PL_lex_state) {
1703 case LEX_NORMAL: /* Some compilers will produce faster */
1704 case LEX_INTERPNORMAL: /* code if we comment these out. */
1708 /* when we're already built the next token, just pull it out the queue */
1711 yylval = PL_nextval[PL_nexttoke];
1713 PL_lex_state = PL_lex_defer;
1714 PL_expect = PL_lex_expect;
1715 PL_lex_defer = LEX_NORMAL;
1717 return(PL_nexttype[PL_nexttoke]);
1719 /* interpolated case modifiers like \L \U, including \Q and \E.
1720 when we get here, PL_bufptr is at the \
1722 case LEX_INTERPCASEMOD:
1724 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1725 croak("panic: INTERPCASEMOD");
1727 /* handle \E or end of string */
1728 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1732 if (PL_lex_casemods) {
1733 oldmod = PL_lex_casestack[--PL_lex_casemods];
1734 PL_lex_casestack[PL_lex_casemods] = '\0';
1736 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1738 PL_lex_state = LEX_INTERPCONCAT;
1742 if (PL_bufptr != PL_bufend)
1744 PL_lex_state = LEX_INTERPCONCAT;
1745 return yylex(PERL_YYLEX_PARAM);
1749 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1750 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1751 if (strchr("LU", *s) &&
1752 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1754 PL_lex_casestack[--PL_lex_casemods] = '\0';
1757 if (PL_lex_casemods > 10) {
1758 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1759 if (newlb != PL_lex_casestack) {
1761 PL_lex_casestack = newlb;
1764 PL_lex_casestack[PL_lex_casemods++] = *s;
1765 PL_lex_casestack[PL_lex_casemods] = '\0';
1766 PL_lex_state = LEX_INTERPCONCAT;
1767 PL_nextval[PL_nexttoke].ival = 0;
1770 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1772 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1774 PL_nextval[PL_nexttoke].ival = OP_LC;
1776 PL_nextval[PL_nexttoke].ival = OP_UC;
1778 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1780 croak("panic: yylex");
1783 if (PL_lex_starts) {
1789 return yylex(PERL_YYLEX_PARAM);
1792 case LEX_INTERPPUSH:
1793 return sublex_push();
1795 case LEX_INTERPSTART:
1796 if (PL_bufptr == PL_bufend)
1797 return sublex_done();
1799 PL_lex_dojoin = (*PL_bufptr == '@');
1800 PL_lex_state = LEX_INTERPNORMAL;
1801 if (PL_lex_dojoin) {
1802 PL_nextval[PL_nexttoke].ival = 0;
1805 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1806 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1807 force_next(PRIVATEREF);
1809 force_ident("\"", '$');
1810 #endif /* USE_THREADS */
1811 PL_nextval[PL_nexttoke].ival = 0;
1813 PL_nextval[PL_nexttoke].ival = 0;
1815 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1818 if (PL_lex_starts++) {
1822 return yylex(PERL_YYLEX_PARAM);
1824 case LEX_INTERPENDMAYBE:
1825 if (intuit_more(PL_bufptr)) {
1826 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1832 if (PL_lex_dojoin) {
1833 PL_lex_dojoin = FALSE;
1834 PL_lex_state = LEX_INTERPCONCAT;
1838 case LEX_INTERPCONCAT:
1840 if (PL_lex_brackets)
1841 croak("panic: INTERPCONCAT");
1843 if (PL_bufptr == PL_bufend)
1844 return sublex_done();
1846 if (SvIVX(PL_linestr) == '\'') {
1847 SV *sv = newSVsv(PL_linestr);
1850 else if ( PL_hints & HINT_NEW_RE )
1851 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1852 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1856 s = scan_const(PL_bufptr);
1858 PL_lex_state = LEX_INTERPCASEMOD;
1860 PL_lex_state = LEX_INTERPSTART;
1863 if (s != PL_bufptr) {
1864 PL_nextval[PL_nexttoke] = yylval;
1867 if (PL_lex_starts++)
1871 return yylex(PERL_YYLEX_PARAM);
1875 return yylex(PERL_YYLEX_PARAM);
1877 PL_lex_state = LEX_NORMAL;
1878 s = scan_formline(PL_bufptr);
1879 if (!PL_lex_formbrack)
1885 PL_oldoldbufptr = PL_oldbufptr;
1888 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1894 if (isIDFIRST_lazy(s))
1896 croak("Unrecognized character \\x%02X", *s & 255);
1899 goto fake_eof; /* emulate EOF on ^D or ^Z */
1904 if (PL_lex_brackets)
1905 yyerror("Missing right bracket");
1908 if (s++ < PL_bufend)
1909 goto retry; /* ignore stray nulls */
1912 if (!PL_in_eval && !PL_preambled) {
1913 PL_preambled = TRUE;
1914 sv_setpv(PL_linestr,incl_perldb());
1915 if (SvCUR(PL_linestr))
1916 sv_catpv(PL_linestr,";");
1918 while(AvFILLp(PL_preambleav) >= 0) {
1919 SV *tmpsv = av_shift(PL_preambleav);
1920 sv_catsv(PL_linestr, tmpsv);
1921 sv_catpv(PL_linestr, ";");
1924 sv_free((SV*)PL_preambleav);
1925 PL_preambleav = NULL;
1927 if (PL_minus_n || PL_minus_p) {
1928 sv_catpv(PL_linestr, "LINE: while (<>) {");
1930 sv_catpv(PL_linestr,"chomp;");
1932 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1934 GvIMPORTED_AV_on(gv);
1936 if (strchr("/'\"", *PL_splitstr)
1937 && strchr(PL_splitstr + 1, *PL_splitstr))
1938 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1941 s = "'~#\200\1'"; /* surely one char is unused...*/
1942 while (s[1] && strchr(PL_splitstr, *s)) s++;
1944 sv_catpvf(PL_linestr, "@F=split(%s%c",
1945 "q" + (delim == '\''), delim);
1946 for (s = PL_splitstr; *s; s++) {
1948 sv_catpvn(PL_linestr, "\\", 1);
1949 sv_catpvn(PL_linestr, s, 1);
1951 sv_catpvf(PL_linestr, "%c);", delim);
1955 sv_catpv(PL_linestr,"@F=split(' ');");
1958 sv_catpv(PL_linestr, "\n");
1959 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1960 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1961 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1962 SV *sv = NEWSV(85,0);
1964 sv_upgrade(sv, SVt_PVMG);
1965 sv_setsv(sv,PL_linestr);
1966 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1971 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1974 if (PL_preprocess && !PL_in_eval)
1975 (void)PerlProc_pclose(PL_rsfp);
1976 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1977 PerlIO_clearerr(PL_rsfp);
1979 (void)PerlIO_close(PL_rsfp);
1981 PL_doextract = FALSE;
1983 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1984 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1985 sv_catpv(PL_linestr,";}");
1986 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1987 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1988 PL_minus_n = PL_minus_p = 0;
1991 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1992 sv_setpv(PL_linestr,"");
1993 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1996 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1997 PL_doextract = FALSE;
1999 /* Incest with pod. */
2000 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2001 sv_setpv(PL_linestr, "");
2002 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2003 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2004 PL_doextract = FALSE;
2008 } while (PL_doextract);
2009 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2010 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2011 SV *sv = NEWSV(85,0);
2013 sv_upgrade(sv, SVt_PVMG);
2014 sv_setsv(sv,PL_linestr);
2015 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2017 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2018 if (PL_curcop->cop_line == 1) {
2019 while (s < PL_bufend && isSPACE(*s))
2021 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2025 if (*s == '#' && *(s+1) == '!')
2027 #ifdef ALTERNATE_SHEBANG
2029 static char as[] = ALTERNATE_SHEBANG;
2030 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2031 d = s + (sizeof(as) - 1);
2033 #endif /* ALTERNATE_SHEBANG */
2042 while (*d && !isSPACE(*d))
2046 #ifdef ARG_ZERO_IS_SCRIPT
2047 if (ipathend > ipath) {
2049 * HP-UX (at least) sets argv[0] to the script name,
2050 * which makes $^X incorrect. And Digital UNIX and Linux,
2051 * at least, set argv[0] to the basename of the Perl
2052 * interpreter. So, having found "#!", we'll set it right.
2054 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2055 assert(SvPOK(x) || SvGMAGICAL(x));
2056 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2057 sv_setpvn(x, ipath, ipathend - ipath);
2060 TAINT_NOT; /* $^X is always tainted, but that's OK */
2062 #endif /* ARG_ZERO_IS_SCRIPT */
2067 d = instr(s,"perl -");
2069 d = instr(s,"perl");
2070 #ifdef ALTERNATE_SHEBANG
2072 * If the ALTERNATE_SHEBANG on this system starts with a
2073 * character that can be part of a Perl expression, then if
2074 * we see it but not "perl", we're probably looking at the
2075 * start of Perl code, not a request to hand off to some
2076 * other interpreter. Similarly, if "perl" is there, but
2077 * not in the first 'word' of the line, we assume the line
2078 * contains the start of the Perl program.
2080 if (d && *s != '#') {
2082 while (*c && !strchr("; \t\r\n\f\v#", *c))
2085 d = Nullch; /* "perl" not in first word; ignore */
2087 *s = '#'; /* Don't try to parse shebang line */
2089 #endif /* ALTERNATE_SHEBANG */
2094 !instr(s,"indir") &&
2095 instr(PL_origargv[0],"perl"))
2101 while (s < PL_bufend && isSPACE(*s))
2103 if (s < PL_bufend) {
2104 Newz(899,newargv,PL_origargc+3,char*);
2106 while (s < PL_bufend && !isSPACE(*s))
2109 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2112 newargv = PL_origargv;
2114 execv(ipath, newargv);
2115 croak("Can't exec %s", ipath);
2118 U32 oldpdb = PL_perldb;
2119 bool oldn = PL_minus_n;
2120 bool oldp = PL_minus_p;
2122 while (*d && !isSPACE(*d)) d++;
2123 while (*d == ' ' || *d == '\t') d++;
2127 if (*d == 'M' || *d == 'm') {
2129 while (*d && !isSPACE(*d)) d++;
2130 croak("Too late for \"-%.*s\" option",
2133 d = moreswitches(d);
2135 if (PERLDB_LINE && !oldpdb ||
2136 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2137 /* if we have already added "LINE: while (<>) {",
2138 we must not do it again */
2140 sv_setpv(PL_linestr, "");
2141 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2142 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2143 PL_preambled = FALSE;
2145 (void)gv_fetchfile(PL_origfilename);
2152 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2154 PL_lex_state = LEX_FORMLINE;
2155 return yylex(PERL_YYLEX_PARAM);
2159 #ifdef PERL_STRICT_CR
2160 warn("Illegal character \\%03o (carriage return)", '\r');
2162 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2164 case ' ': case '\t': case '\f': case 013:
2169 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2171 while (s < d && *s != '\n')
2176 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2178 PL_lex_state = LEX_FORMLINE;
2179 return yylex(PERL_YYLEX_PARAM);
2188 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2193 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2196 if (strnEQ(s,"=>",2)) {
2197 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2198 OPERATOR('-'); /* unary minus */
2200 PL_last_uni = PL_oldbufptr;
2201 PL_last_lop_op = OP_FTEREAD; /* good enough */
2203 case 'r': FTST(OP_FTEREAD);
2204 case 'w': FTST(OP_FTEWRITE);
2205 case 'x': FTST(OP_FTEEXEC);
2206 case 'o': FTST(OP_FTEOWNED);
2207 case 'R': FTST(OP_FTRREAD);
2208 case 'W': FTST(OP_FTRWRITE);
2209 case 'X': FTST(OP_FTREXEC);
2210 case 'O': FTST(OP_FTROWNED);
2211 case 'e': FTST(OP_FTIS);
2212 case 'z': FTST(OP_FTZERO);
2213 case 's': FTST(OP_FTSIZE);
2214 case 'f': FTST(OP_FTFILE);
2215 case 'd': FTST(OP_FTDIR);
2216 case 'l': FTST(OP_FTLINK);
2217 case 'p': FTST(OP_FTPIPE);
2218 case 'S': FTST(OP_FTSOCK);
2219 case 'u': FTST(OP_FTSUID);
2220 case 'g': FTST(OP_FTSGID);
2221 case 'k': FTST(OP_FTSVTX);
2222 case 'b': FTST(OP_FTBLK);
2223 case 'c': FTST(OP_FTCHR);
2224 case 't': FTST(OP_FTTTY);
2225 case 'T': FTST(OP_FTTEXT);
2226 case 'B': FTST(OP_FTBINARY);
2227 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2228 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2229 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2231 croak("Unrecognized file test: -%c", (int)tmp);
2238 if (PL_expect == XOPERATOR)
2243 else if (*s == '>') {
2246 if (isIDFIRST_lazy(s)) {
2247 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2255 if (PL_expect == XOPERATOR)
2258 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2260 OPERATOR('-'); /* unary minus */
2267 if (PL_expect == XOPERATOR)
2272 if (PL_expect == XOPERATOR)
2275 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2281 if (PL_expect != XOPERATOR) {
2282 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2283 PL_expect = XOPERATOR;
2284 force_ident(PL_tokenbuf, '*');
2297 if (PL_expect == XOPERATOR) {
2301 PL_tokenbuf[0] = '%';
2302 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2303 if (!PL_tokenbuf[1]) {
2305 yyerror("Final % should be \\% or %name");
2308 PL_pending_ident = '%';
2330 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2331 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2336 if (PL_curcop->cop_line < PL_copline)
2337 PL_copline = PL_curcop->cop_line;
2348 if (PL_lex_brackets <= 0)
2349 yyerror("Unmatched right bracket");
2352 if (PL_lex_state == LEX_INTERPNORMAL) {
2353 if (PL_lex_brackets == 0) {
2354 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2355 PL_lex_state = LEX_INTERPEND;
2362 if (PL_lex_brackets > 100) {
2363 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2364 if (newlb != PL_lex_brackstack) {
2366 PL_lex_brackstack = newlb;
2369 switch (PL_expect) {
2371 if (PL_lex_formbrack) {
2375 if (PL_oldoldbufptr == PL_last_lop)
2376 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2378 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2379 OPERATOR(HASHBRACK);
2381 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2384 PL_tokenbuf[0] = '\0';
2385 if (d < PL_bufend && *d == '-') {
2386 PL_tokenbuf[0] = '-';
2388 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2391 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2392 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2394 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2397 char minus = (PL_tokenbuf[0] == '-');
2398 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2405 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2409 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2414 if (PL_oldoldbufptr == PL_last_lop)
2415 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2417 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2420 OPERATOR(HASHBRACK);
2421 /* This hack serves to disambiguate a pair of curlies
2422 * as being a block or an anon hash. Normally, expectation
2423 * determines that, but in cases where we're not in a
2424 * position to expect anything in particular (like inside
2425 * eval"") we have to resolve the ambiguity. This code
2426 * covers the case where the first term in the curlies is a
2427 * quoted string. Most other cases need to be explicitly
2428 * disambiguated by prepending a `+' before the opening
2429 * curly in order to force resolution as an anon hash.
2431 * XXX should probably propagate the outer expectation
2432 * into eval"" to rely less on this hack, but that could
2433 * potentially break current behavior of eval"".
2437 if (*s == '\'' || *s == '"' || *s == '`') {
2438 /* common case: get past first string, handling escapes */
2439 for (t++; t < PL_bufend && *t != *s;)
2440 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2444 else if (*s == 'q') {
2447 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2448 && !isALNUM(*t)))) {
2450 char open, close, term;
2453 while (t < PL_bufend && isSPACE(*t))
2457 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2461 for (t++; t < PL_bufend; t++) {
2462 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2464 else if (*t == open)
2468 for (t++; t < PL_bufend; t++) {
2469 if (*t == '\\' && t+1 < PL_bufend)
2471 else if (*t == close && --brackets <= 0)
2473 else if (*t == open)
2479 else if (isIDFIRST_lazy(s)) {
2480 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2482 while (t < PL_bufend && isSPACE(*t))
2484 /* if comma follows first term, call it an anon hash */
2485 /* XXX it could be a comma expression with loop modifiers */
2486 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2487 || (*t == '=' && t[1] == '>')))
2488 OPERATOR(HASHBRACK);
2489 if (PL_expect == XREF)
2490 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2492 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2498 yylval.ival = PL_curcop->cop_line;
2499 if (isSPACE(*s) || *s == '#')
2500 PL_copline = NOLINE; /* invalidate current command line number */
2505 if (PL_lex_brackets <= 0)
2506 yyerror("Unmatched right bracket");
2508 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2509 if (PL_lex_brackets < PL_lex_formbrack)
2510 PL_lex_formbrack = 0;
2511 if (PL_lex_state == LEX_INTERPNORMAL) {
2512 if (PL_lex_brackets == 0) {
2513 if (PL_lex_fakebrack) {
2514 PL_lex_state = LEX_INTERPEND;
2516 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2518 if (*s == '-' && s[1] == '>')
2519 PL_lex_state = LEX_INTERPENDMAYBE;
2520 else if (*s != '[' && *s != '{')
2521 PL_lex_state = LEX_INTERPEND;
2524 if (PL_lex_brackets < PL_lex_fakebrack) {
2526 PL_lex_fakebrack = 0;
2527 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2537 if (PL_expect == XOPERATOR) {
2538 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2539 PL_curcop->cop_line--;
2540 warner(WARN_SEMICOLON, PL_warn_nosemi);
2541 PL_curcop->cop_line++;
2546 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2548 PL_expect = XOPERATOR;
2549 force_ident(PL_tokenbuf, '&');
2553 yylval.ival = (OPpENTERSUB_AMPER<<8);
2572 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2573 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2575 if (PL_expect == XSTATE && isALPHA(tmp) &&
2576 (s == PL_linestart+1 || s[-2] == '\n') )
2578 if (PL_in_eval && !PL_rsfp) {
2583 if (strnEQ(s,"=cut",4)) {
2597 PL_doextract = TRUE;
2600 if (PL_lex_brackets < PL_lex_formbrack) {
2602 #ifdef PERL_STRICT_CR
2603 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2605 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2607 if (*t == '\n' || *t == '#') {
2625 if (PL_expect != XOPERATOR) {
2626 if (s[1] != '<' && !strchr(s,'>'))
2629 s = scan_heredoc(s);
2631 s = scan_inputsymbol(s);
2632 TERM(sublex_start());
2637 SHop(OP_LEFT_SHIFT);
2651 SHop(OP_RIGHT_SHIFT);
2660 if (PL_expect == XOPERATOR) {
2661 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2664 return ','; /* grandfather non-comma-format format */
2668 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2669 if (PL_expect == XOPERATOR)
2670 no_op("Array length", PL_bufptr);
2671 PL_tokenbuf[0] = '@';
2672 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2674 if (!PL_tokenbuf[1])
2676 PL_expect = XOPERATOR;
2677 PL_pending_ident = '#';
2681 if (PL_expect == XOPERATOR)
2682 no_op("Scalar", PL_bufptr);
2683 PL_tokenbuf[0] = '$';
2684 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2685 if (!PL_tokenbuf[1]) {
2687 yyerror("Final $ should be \\$ or $name");
2691 /* This kludge not intended to be bulletproof. */
2692 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2693 yylval.opval = newSVOP(OP_CONST, 0,
2694 newSViv((IV)PL_compiling.cop_arybase));
2695 yylval.opval->op_private = OPpCONST_ARYBASE;
2700 if (PL_lex_state == LEX_NORMAL)
2703 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2706 PL_tokenbuf[0] = '@';
2707 if (ckWARN(WARN_SYNTAX)) {
2709 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2712 PL_bufptr = skipspace(PL_bufptr);
2713 while (t < PL_bufend && *t != ']')
2716 "Multidimensional syntax %.*s not supported",
2717 (t - PL_bufptr) + 1, PL_bufptr);
2721 else if (*s == '{') {
2722 PL_tokenbuf[0] = '%';
2723 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2724 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2726 char tmpbuf[sizeof PL_tokenbuf];
2728 for (t++; isSPACE(*t); t++) ;
2729 if (isIDFIRST_lazy(t)) {
2730 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2731 for (; isSPACE(*t); t++) ;
2732 if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
2734 "You need to quote \"%s\"", tmpbuf);
2740 PL_expect = XOPERATOR;
2741 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2742 bool islop = (PL_last_lop == PL_oldoldbufptr);
2743 if (!islop || PL_last_lop_op == OP_GREPSTART)
2744 PL_expect = XOPERATOR;
2745 else if (strchr("$@\"'`q", *s))
2746 PL_expect = XTERM; /* e.g. print $fh "foo" */
2747 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2748 PL_expect = XTERM; /* e.g. print $fh &sub */
2749 else if (isIDFIRST_lazy(s)) {
2750 char tmpbuf[sizeof PL_tokenbuf];
2751 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2752 if (tmp = keyword(tmpbuf, len)) {
2753 /* binary operators exclude handle interpretations */
2765 PL_expect = XTERM; /* e.g. print $fh length() */
2770 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2771 if (gv && GvCVu(gv))
2772 PL_expect = XTERM; /* e.g. print $fh subr() */
2775 else if (isDIGIT(*s))
2776 PL_expect = XTERM; /* e.g. print $fh 3 */
2777 else if (*s == '.' && isDIGIT(s[1]))
2778 PL_expect = XTERM; /* e.g. print $fh .3 */
2779 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2780 PL_expect = XTERM; /* e.g. print $fh -1 */
2781 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2782 PL_expect = XTERM; /* print $fh <<"EOF" */
2784 PL_pending_ident = '$';
2788 if (PL_expect == XOPERATOR)
2790 PL_tokenbuf[0] = '@';
2791 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2792 if (!PL_tokenbuf[1]) {
2794 yyerror("Final @ should be \\@ or @name");
2797 if (PL_lex_state == LEX_NORMAL)
2799 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2801 PL_tokenbuf[0] = '%';
2803 /* Warn about @ where they meant $. */
2804 if (ckWARN(WARN_SYNTAX)) {
2805 if (*s == '[' || *s == '{') {
2807 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2809 if (*t == '}' || *t == ']') {
2811 PL_bufptr = skipspace(PL_bufptr);
2813 "Scalar value %.*s better written as $%.*s",
2814 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2819 PL_pending_ident = '@';
2822 case '/': /* may either be division or pattern */
2823 case '?': /* may either be conditional or pattern */
2824 if (PL_expect != XOPERATOR) {
2825 /* Disable warning on "study /blah/" */
2826 if (PL_oldoldbufptr == PL_last_uni
2827 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2828 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2830 s = scan_pat(s,OP_MATCH);
2831 TERM(sublex_start());
2839 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2840 #ifdef PERL_STRICT_CR
2843 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2845 && (s == PL_linestart || s[-1] == '\n') )
2847 PL_lex_formbrack = 0;
2851 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2857 yylval.ival = OPf_SPECIAL;
2863 if (PL_expect != XOPERATOR)
2868 case '0': case '1': case '2': case '3': case '4':
2869 case '5': case '6': case '7': case '8': case '9':
2871 if (PL_expect == XOPERATOR)
2877 if (PL_expect == XOPERATOR) {
2878 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2881 return ','; /* grandfather non-comma-format format */
2887 missingterm((char*)0);
2888 yylval.ival = OP_CONST;
2889 TERM(sublex_start());
2893 if (PL_expect == XOPERATOR) {
2894 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2897 return ','; /* grandfather non-comma-format format */
2903 missingterm((char*)0);
2904 yylval.ival = OP_CONST;
2905 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2906 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2907 yylval.ival = OP_STRINGIFY;
2911 TERM(sublex_start());
2915 if (PL_expect == XOPERATOR)
2916 no_op("Backticks",s);
2918 missingterm((char*)0);
2919 yylval.ival = OP_BACKTICK;
2921 TERM(sublex_start());
2925 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2926 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2928 if (PL_expect == XOPERATOR)
2929 no_op("Backslash",s);
2933 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2972 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2974 /* Some keywords can be followed by any delimiter, including ':' */
2975 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2976 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2977 (PL_tokenbuf[0] == 'q' &&
2978 strchr("qwxr", PL_tokenbuf[1]))));
2980 /* x::* is just a word, unless x is "CORE" */
2981 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2985 while (d < PL_bufend && isSPACE(*d))
2986 d++; /* no comments skipped here, or s### is misparsed */
2988 /* Is this a label? */
2989 if (!tmp && PL_expect == XSTATE
2990 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2992 yylval.pval = savepv(PL_tokenbuf);
2997 /* Check for keywords */
2998 tmp = keyword(PL_tokenbuf, len);
3000 /* Is this a word before a => operator? */
3001 if (strnEQ(d,"=>",2)) {
3003 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3004 yylval.opval->op_private = OPpCONST_BARE;
3008 if (tmp < 0) { /* second-class keyword? */
3009 GV *ogv = Nullgv; /* override (winner) */
3010 GV *hgv = Nullgv; /* hidden (loser) */
3011 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3013 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3016 if (GvIMPORTED_CV(gv))
3018 else if (! CvMETHOD(cv))
3022 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3023 (gv = *gvp) != (GV*)&PL_sv_undef &&
3024 GvCVu(gv) && GvIMPORTED_CV(gv))
3030 tmp = 0; /* overridden by import or by GLOBAL */
3033 && -tmp==KEY_lock /* XXX generalizable kludge */
3034 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3036 tmp = 0; /* any sub overrides "weak" keyword */
3038 else { /* no override */
3042 if (ckWARN(WARN_AMBIGUOUS) && hgv
3043 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3044 warner(WARN_AMBIGUOUS,
3045 "Ambiguous call resolved as CORE::%s(), %s",
3046 GvENAME(hgv), "qualify as such or use &");
3053 default: /* not a keyword */
3056 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3058 /* Get the rest if it looks like a package qualifier */
3060 if (*s == '\'' || *s == ':' && s[1] == ':') {
3062 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3065 croak("Bad name after %s%s", PL_tokenbuf,
3066 *s == '\'' ? "'" : "::");
3070 if (PL_expect == XOPERATOR) {
3071 if (PL_bufptr == PL_linestart) {
3072 PL_curcop->cop_line--;
3073 warner(WARN_SEMICOLON, PL_warn_nosemi);
3074 PL_curcop->cop_line++;
3077 no_op("Bareword",s);
3080 /* Look for a subroutine with this name in current package,
3081 unless name is "Foo::", in which case Foo is a bearword
3082 (and a package name). */
3085 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3087 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3089 "Bareword \"%s\" refers to nonexistent package",
3092 PL_tokenbuf[len] = '\0';
3099 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3102 /* if we saw a global override before, get the right name */
3105 sv = newSVpv("CORE::GLOBAL::",14);
3106 sv_catpv(sv,PL_tokenbuf);
3109 sv = newSVpv(PL_tokenbuf,0);
3111 /* Presume this is going to be a bareword of some sort. */
3114 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3115 yylval.opval->op_private = OPpCONST_BARE;
3117 /* And if "Foo::", then that's what it certainly is. */
3122 /* See if it's the indirect object for a list operator. */
3124 if (PL_oldoldbufptr &&
3125 PL_oldoldbufptr < PL_bufptr &&
3126 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3127 /* NO SKIPSPACE BEFORE HERE! */
3129 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3130 || (PL_last_lop_op == OP_ENTERSUB
3132 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3134 bool immediate_paren = *s == '(';
3136 /* (Now we can afford to cross potential line boundary.) */
3139 /* Two barewords in a row may indicate method call. */
3141 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3144 /* If not a declared subroutine, it's an indirect object. */
3145 /* (But it's an indir obj regardless for sort.) */
3147 if ((PL_last_lop_op == OP_SORT ||
3148 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3149 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3150 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3155 /* If followed by a paren, it's certainly a subroutine. */
3157 PL_expect = XOPERATOR;
3161 if (gv && GvCVu(gv)) {
3163 if ((cv = GvCV(gv)) && SvPOK(cv))
3164 PL_last_proto = SvPV((SV*)cv, PL_na);
3165 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3166 if (*d == ')' && (sv = cv_const_sv(cv))) {
3171 PL_nextval[PL_nexttoke].opval = yylval.opval;
3172 PL_expect = XOPERATOR;
3175 PL_last_lop_op = OP_ENTERSUB;
3179 /* If followed by var or block, call it a method (unless sub) */
3181 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3182 PL_last_lop = PL_oldbufptr;
3183 PL_last_lop_op = OP_METHOD;
3187 /* If followed by a bareword, see if it looks like indir obj. */
3189 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3192 /* Not a method, so call it a subroutine (if defined) */
3194 if (gv && GvCVu(gv)) {
3196 if (lastchar == '-')
3197 warn("Ambiguous use of -%s resolved as -&%s()",
3198 PL_tokenbuf, PL_tokenbuf);
3199 PL_last_lop = PL_oldbufptr;
3200 PL_last_lop_op = OP_ENTERSUB;
3201 /* Check for a constant sub */
3203 if ((sv = cv_const_sv(cv))) {
3205 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3206 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3207 yylval.opval->op_private = 0;
3211 /* Resolve to GV now. */
3212 op_free(yylval.opval);
3213 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3214 PL_last_lop_op = OP_ENTERSUB;
3215 /* Is there a prototype? */
3218 PL_last_proto = SvPV((SV*)cv, len);
3221 if (strEQ(PL_last_proto, "$"))
3223 if (*PL_last_proto == '&' && *s == '{') {
3224 sv_setpv(PL_subname,"__ANON__");
3228 PL_last_proto = NULL;
3229 PL_nextval[PL_nexttoke].opval = yylval.opval;
3235 if (PL_hints & HINT_STRICT_SUBS &&
3238 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3239 PL_last_lop_op != OP_ACCEPT &&
3240 PL_last_lop_op != OP_PIPE_OP &&
3241 PL_last_lop_op != OP_SOCKPAIR &&
3242 !(PL_last_lop_op == OP_ENTERSUB
3244 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3247 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3252 /* Call it a bare word */
3255 if (ckWARN(WARN_RESERVED)) {
3256 if (lastchar != '-') {
3257 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3259 warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
3264 if (lastchar && strchr("*%&", lastchar)) {
3265 warn("Operator or semicolon missing before %c%s",
3266 lastchar, PL_tokenbuf);
3267 warn("Ambiguous use of %c resolved as operator %c",
3268 lastchar, lastchar);
3274 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3275 newSVsv(GvSV(PL_curcop->cop_filegv)));
3279 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3280 newSVpvf("%ld", (long)PL_curcop->cop_line));
3283 case KEY___PACKAGE__:
3284 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3286 ? newSVsv(PL_curstname)
3295 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3296 char *pname = "main";
3297 if (PL_tokenbuf[2] == 'D')
3298 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3299 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3302 GvIOp(gv) = newIO();
3303 IoIFP(GvIOp(gv)) = PL_rsfp;
3304 #if defined(HAS_FCNTL) && defined(F_SETFD)
3306 int fd = PerlIO_fileno(PL_rsfp);
3307 fcntl(fd,F_SETFD,fd >= 3);
3310 /* Mark this internal pseudo-handle as clean */
3311 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3313 IoTYPE(GvIOp(gv)) = '|';
3314 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3315 IoTYPE(GvIOp(gv)) = '-';
3317 IoTYPE(GvIOp(gv)) = '<';
3328 if (PL_expect == XSTATE) {
3335 if (*s == ':' && s[1] == ':') {
3338 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3339 tmp = keyword(PL_tokenbuf, len);
3353 LOP(OP_ACCEPT,XTERM);
3359 LOP(OP_ATAN2,XTERM);
3368 LOP(OP_BLESS,XTERM);
3377 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3394 if (!PL_cryptseen++)
3397 LOP(OP_CRYPT,XTERM);
3400 if (ckWARN(WARN_OCTAL)) {
3401 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3402 if (*d != '0' && isDIGIT(*d))
3403 yywarn("chmod: mode argument is missing initial 0");
3405 LOP(OP_CHMOD,XTERM);
3408 LOP(OP_CHOWN,XTERM);
3411 LOP(OP_CONNECT,XTERM);
3427 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3431 PL_hints |= HINT_BLOCK_SCOPE;
3441 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3442 LOP(OP_DBMOPEN,XTERM);
3448 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3455 yylval.ival = PL_curcop->cop_line;
3469 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3470 UNIBRACK(OP_ENTEREVAL);
3485 case KEY_endhostent:
3491 case KEY_endservent:
3494 case KEY_endprotoent:
3505 yylval.ival = PL_curcop->cop_line;
3507 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3509 if ((PL_bufend - p) >= 3 &&
3510 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3513 if (isIDFIRST_lazy(p))
3514 croak("Missing $ on loop variable");
3519 LOP(OP_FORMLINE,XTERM);
3525 LOP(OP_FCNTL,XTERM);
3531 LOP(OP_FLOCK,XTERM);
3540 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3543 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3558 case KEY_getpriority:
3559 LOP(OP_GETPRIORITY,XTERM);
3561 case KEY_getprotobyname:
3564 case KEY_getprotobynumber:
3565 LOP(OP_GPBYNUMBER,XTERM);
3567 case KEY_getprotoent:
3579 case KEY_getpeername:
3580 UNI(OP_GETPEERNAME);
3582 case KEY_gethostbyname:
3585 case KEY_gethostbyaddr:
3586 LOP(OP_GHBYADDR,XTERM);
3588 case KEY_gethostent:
3591 case KEY_getnetbyname:
3594 case KEY_getnetbyaddr:
3595 LOP(OP_GNBYADDR,XTERM);
3600 case KEY_getservbyname:
3601 LOP(OP_GSBYNAME,XTERM);
3603 case KEY_getservbyport:
3604 LOP(OP_GSBYPORT,XTERM);
3606 case KEY_getservent:
3609 case KEY_getsockname:
3610 UNI(OP_GETSOCKNAME);
3612 case KEY_getsockopt:
3613 LOP(OP_GSOCKOPT,XTERM);
3635 yylval.ival = PL_curcop->cop_line;
3639 LOP(OP_INDEX,XTERM);
3645 LOP(OP_IOCTL,XTERM);
3657 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3688 LOP(OP_LISTEN,XTERM);
3697 s = scan_pat(s,OP_MATCH);
3698 TERM(sublex_start());
3701 LOP(OP_MAPSTART, XREF);
3704 LOP(OP_MKDIR,XTERM);
3707 LOP(OP_MSGCTL,XTERM);
3710 LOP(OP_MSGGET,XTERM);
3713 LOP(OP_MSGRCV,XTERM);
3716 LOP(OP_MSGSND,XTERM);
3721 if (isIDFIRST_lazy(s)) {
3722 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3723 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3724 if (!PL_in_my_stash) {
3727 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3734 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3741 if (PL_expect != XSTATE)
3742 yyerror("\"no\" not allowed in expression");
3743 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3744 s = force_version(s);
3753 if (isIDFIRST_lazy(s)) {
3755 for (d = s; isALNUM_lazy(d); d++) ;
3757 if (strchr("|&*+-=!?:.", *t))
3758 warn("Precedence problem: open %.*s should be open(%.*s)",
3764 yylval.ival = OP_OR;
3774 LOP(OP_OPEN_DIR,XTERM);
3777 checkcomma(s,PL_tokenbuf,"filehandle");
3781 checkcomma(s,PL_tokenbuf,"filehandle");
3800 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3804 LOP(OP_PIPE_OP,XTERM);
3809 missingterm((char*)0);
3810 yylval.ival = OP_CONST;
3811 TERM(sublex_start());
3819 missingterm((char*)0);
3820 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3821 d = SvPV_force(PL_lex_stuff, len);
3822 for (; len; --len, ++d) {
3825 "Possible attempt to separate words with commas");
3830 "Possible attempt to put comments in qw() list");
3836 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3837 PL_lex_stuff = Nullsv;
3840 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3843 yylval.ival = OP_SPLIT;
3847 PL_last_lop = PL_oldbufptr;
3848 PL_last_lop_op = OP_SPLIT;
3854 missingterm((char*)0);
3855 yylval.ival = OP_STRINGIFY;
3856 if (SvIVX(PL_lex_stuff) == '\'')
3857 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3858 TERM(sublex_start());
3861 s = scan_pat(s,OP_QR);
3862 TERM(sublex_start());
3867 missingterm((char*)0);
3868 yylval.ival = OP_BACKTICK;
3870 TERM(sublex_start());
3876 *PL_tokenbuf = '\0';
3877 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3878 if (isIDFIRST_lazy(PL_tokenbuf))
3879 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3881 yyerror("<> should be quotes");
3888 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3892 LOP(OP_RENAME,XTERM);
3901 LOP(OP_RINDEX,XTERM);
3924 LOP(OP_REVERSE,XTERM);
3935 TERM(sublex_start());
3937 TOKEN(1); /* force error */
3946 LOP(OP_SELECT,XTERM);
3952 LOP(OP_SEMCTL,XTERM);
3955 LOP(OP_SEMGET,XTERM);
3958 LOP(OP_SEMOP,XTERM);
3964 LOP(OP_SETPGRP,XTERM);
3966 case KEY_setpriority:
3967 LOP(OP_SETPRIORITY,XTERM);
3969 case KEY_sethostent:
3975 case KEY_setservent:
3978 case KEY_setprotoent:
3988 LOP(OP_SEEKDIR,XTERM);
3990 case KEY_setsockopt:
3991 LOP(OP_SSOCKOPT,XTERM);
3997 LOP(OP_SHMCTL,XTERM);
4000 LOP(OP_SHMGET,XTERM);
4003 LOP(OP_SHMREAD,XTERM);
4006 LOP(OP_SHMWRITE,XTERM);
4009 LOP(OP_SHUTDOWN,XTERM);
4018 LOP(OP_SOCKET,XTERM);
4020 case KEY_socketpair:
4021 LOP(OP_SOCKPAIR,XTERM);
4024 checkcomma(s,PL_tokenbuf,"subroutine name");
4026 if (*s == ';' || *s == ')') /* probably a close */
4027 croak("sort is now a reserved word");
4029 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4033 LOP(OP_SPLIT,XTERM);
4036 LOP(OP_SPRINTF,XTERM);
4039 LOP(OP_SPLICE,XTERM);
4055 LOP(OP_SUBSTR,XTERM);
4062 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4063 char tmpbuf[sizeof PL_tokenbuf];
4065 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4066 if (strchr(tmpbuf, ':'))
4067 sv_setpv(PL_subname, tmpbuf);
4069 sv_setsv(PL_subname,PL_curstname);
4070 sv_catpvn(PL_subname,"::",2);
4071 sv_catpvn(PL_subname,tmpbuf,len);
4073 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4077 PL_expect = XTERMBLOCK;
4078 sv_setpv(PL_subname,"?");
4081 if (tmp == KEY_format) {
4084 PL_lex_formbrack = PL_lex_brackets + 1;
4088 /* Look for a prototype */
4095 SvREFCNT_dec(PL_lex_stuff);
4096 PL_lex_stuff = Nullsv;
4097 croak("Prototype not terminated");
4100 d = SvPVX(PL_lex_stuff);
4102 for (p = d; *p; ++p) {
4107 SvCUR(PL_lex_stuff) = tmp;
4110 PL_nextval[1] = PL_nextval[0];
4111 PL_nexttype[1] = PL_nexttype[0];
4112 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4113 PL_nexttype[0] = THING;
4114 if (PL_nexttoke == 1) {
4115 PL_lex_defer = PL_lex_state;
4116 PL_lex_expect = PL_expect;
4117 PL_lex_state = LEX_KNOWNEXT;
4119 PL_lex_stuff = Nullsv;
4122 if (*SvPV(PL_subname,PL_na) == '?') {
4123 sv_setpv(PL_subname,"__ANON__");
4130 LOP(OP_SYSTEM,XREF);
4133 LOP(OP_SYMLINK,XTERM);
4136 LOP(OP_SYSCALL,XTERM);
4139 LOP(OP_SYSOPEN,XTERM);
4142 LOP(OP_SYSSEEK,XTERM);
4145 LOP(OP_SYSREAD,XTERM);
4148 LOP(OP_SYSWRITE,XTERM);
4152 TERM(sublex_start());
4173 LOP(OP_TRUNCATE,XTERM);
4185 yylval.ival = PL_curcop->cop_line;
4189 yylval.ival = PL_curcop->cop_line;
4193 LOP(OP_UNLINK,XTERM);
4199 LOP(OP_UNPACK,XTERM);
4202 LOP(OP_UTIME,XTERM);
4205 if (ckWARN(WARN_OCTAL)) {
4206 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4207 if (*d != '0' && isDIGIT(*d))
4208 yywarn("umask: argument is missing initial 0");
4213 LOP(OP_UNSHIFT,XTERM);
4216 if (PL_expect != XSTATE)
4217 yyerror("\"use\" not allowed in expression");
4220 s = force_version(s);
4221 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4222 PL_nextval[PL_nexttoke].opval = Nullop;
4227 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4228 s = force_version(s);
4241 yylval.ival = PL_curcop->cop_line;
4245 PL_hints |= HINT_BLOCK_SCOPE;
4252 LOP(OP_WAITPID,XTERM);
4260 static char ctl_l[2];
4262 if (ctl_l[0] == '\0')
4263 ctl_l[0] = toCTRL('L');
4264 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4267 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4272 if (PL_expect == XOPERATOR)
4278 yylval.ival = OP_XOR;
4283 TERM(sublex_start());
4289 keyword(register char *d, I32 len)
4294 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4295 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4296 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4297 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4298 if (strEQ(d,"__END__")) return KEY___END__;
4302 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4307 if (strEQ(d,"and")) return -KEY_and;
4308 if (strEQ(d,"abs")) return -KEY_abs;
4311 if (strEQ(d,"alarm")) return -KEY_alarm;
4312 if (strEQ(d,"atan2")) return -KEY_atan2;
4315 if (strEQ(d,"accept")) return -KEY_accept;
4320 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4323 if (strEQ(d,"bless")) return -KEY_bless;
4324 if (strEQ(d,"bind")) return -KEY_bind;
4325 if (strEQ(d,"binmode")) return -KEY_binmode;
4328 if (strEQ(d,"CORE")) return -KEY_CORE;
4333 if (strEQ(d,"cmp")) return -KEY_cmp;
4334 if (strEQ(d,"chr")) return -KEY_chr;
4335 if (strEQ(d,"cos")) return -KEY_cos;
4338 if (strEQ(d,"chop")) return KEY_chop;
4341 if (strEQ(d,"close")) return -KEY_close;
4342 if (strEQ(d,"chdir")) return -KEY_chdir;
4343 if (strEQ(d,"chomp")) return KEY_chomp;
4344 if (strEQ(d,"chmod")) return -KEY_chmod;
4345 if (strEQ(d,"chown")) return -KEY_chown;
4346 if (strEQ(d,"crypt")) return -KEY_crypt;
4349 if (strEQ(d,"chroot")) return -KEY_chroot;
4350 if (strEQ(d,"caller")) return -KEY_caller;
4353 if (strEQ(d,"connect")) return -KEY_connect;
4356 if (strEQ(d,"closedir")) return -KEY_closedir;
4357 if (strEQ(d,"continue")) return -KEY_continue;
4362 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4367 if (strEQ(d,"do")) return KEY_do;
4370 if (strEQ(d,"die")) return -KEY_die;
4373 if (strEQ(d,"dump")) return -KEY_dump;
4376 if (strEQ(d,"delete")) return KEY_delete;
4379 if (strEQ(d,"defined")) return KEY_defined;
4380 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4383 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4388 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4389 if (strEQ(d,"END")) return KEY_END;
4394 if (strEQ(d,"eq")) return -KEY_eq;
4397 if (strEQ(d,"eof")) return -KEY_eof;
4398 if (strEQ(d,"exp")) return -KEY_exp;
4401 if (strEQ(d,"else")) return KEY_else;
4402 if (strEQ(d,"exit")) return -KEY_exit;
4403 if (strEQ(d,"eval")) return KEY_eval;
4404 if (strEQ(d,"exec")) return -KEY_exec;
4405 if (strEQ(d,"each")) return KEY_each;
4408 if (strEQ(d,"elsif")) return KEY_elsif;
4411 if (strEQ(d,"exists")) return KEY_exists;
4412 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4415 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4416 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4419 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4422 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4423 if (strEQ(d,"endservent")) return -KEY_endservent;
4426 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4433 if (strEQ(d,"for")) return KEY_for;
4436 if (strEQ(d,"fork")) return -KEY_fork;
4439 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4440 if (strEQ(d,"flock")) return -KEY_flock;
4443 if (strEQ(d,"format")) return KEY_format;
4444 if (strEQ(d,"fileno")) return -KEY_fileno;
4447 if (strEQ(d,"foreach")) return KEY_foreach;
4450 if (strEQ(d,"formline")) return -KEY_formline;
4456 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4457 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4461 if (strnEQ(d,"get",3)) {
4466 if (strEQ(d,"ppid")) return -KEY_getppid;
4467 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4470 if (strEQ(d,"pwent")) return -KEY_getpwent;
4471 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4472 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4475 if (strEQ(d,"peername")) return -KEY_getpeername;
4476 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4477 if (strEQ(d,"priority")) return -KEY_getpriority;
4480 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4483 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4487 else if (*d == 'h') {
4488 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4489 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4490 if (strEQ(d,"hostent")) return -KEY_gethostent;
4492 else if (*d == 'n') {
4493 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4494 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4495 if (strEQ(d,"netent")) return -KEY_getnetent;
4497 else if (*d == 's') {
4498 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4499 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4500 if (strEQ(d,"servent")) return -KEY_getservent;
4501 if (strEQ(d,"sockname")) return -KEY_getsockname;
4502 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4504 else if (*d == 'g') {
4505 if (strEQ(d,"grent")) return -KEY_getgrent;
4506 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4507 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4509 else if (*d == 'l') {
4510 if (strEQ(d,"login")) return -KEY_getlogin;
4512 else if (strEQ(d,"c")) return -KEY_getc;
4517 if (strEQ(d,"gt")) return -KEY_gt;
4518 if (strEQ(d,"ge")) return -KEY_ge;
4521 if (strEQ(d,"grep")) return KEY_grep;
4522 if (strEQ(d,"goto")) return KEY_goto;
4523 if (strEQ(d,"glob")) return KEY_glob;
4526 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4531 if (strEQ(d,"hex")) return -KEY_hex;
4534 if (strEQ(d,"INIT")) return KEY_INIT;
4539 if (strEQ(d,"if")) return KEY_if;
4542 if (strEQ(d,"int")) return -KEY_int;
4545 if (strEQ(d,"index")) return -KEY_index;
4546 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4551 if (strEQ(d,"join")) return -KEY_join;
4555 if (strEQ(d,"keys")) return KEY_keys;
4556 if (strEQ(d,"kill")) return -KEY_kill;
4561 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4562 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4568 if (strEQ(d,"lt")) return -KEY_lt;
4569 if (strEQ(d,"le")) return -KEY_le;
4570 if (strEQ(d,"lc")) return -KEY_lc;
4573 if (strEQ(d,"log")) return -KEY_log;
4576 if (strEQ(d,"last")) return KEY_last;
4577 if (strEQ(d,"link")) return -KEY_link;
4578 if (strEQ(d,"lock")) return -KEY_lock;
4581 if (strEQ(d,"local")) return KEY_local;
4582 if (strEQ(d,"lstat")) return -KEY_lstat;
4585 if (strEQ(d,"length")) return -KEY_length;
4586 if (strEQ(d,"listen")) return -KEY_listen;
4589 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4592 if (strEQ(d,"localtime")) return -KEY_localtime;
4598 case 1: return KEY_m;
4600 if (strEQ(d,"my")) return KEY_my;
4603 if (strEQ(d,"map")) return KEY_map;
4606 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4609 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4610 if (strEQ(d,"msgget")) return -KEY_msgget;
4611 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4612 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4617 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4620 if (strEQ(d,"next")) return KEY_next;
4621 if (strEQ(d,"ne")) return -KEY_ne;
4622 if (strEQ(d,"not")) return -KEY_not;
4623 if (strEQ(d,"no")) return KEY_no;
4628 if (strEQ(d,"or")) return -KEY_or;
4631 if (strEQ(d,"ord")) return -KEY_ord;
4632 if (strEQ(d,"oct")) return -KEY_oct;
4633 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4637 if (strEQ(d,"open")) return -KEY_open;
4640 if (strEQ(d,"opendir")) return -KEY_opendir;
4647 if (strEQ(d,"pop")) return KEY_pop;
4648 if (strEQ(d,"pos")) return KEY_pos;
4651 if (strEQ(d,"push")) return KEY_push;
4652 if (strEQ(d,"pack")) return -KEY_pack;
4653 if (strEQ(d,"pipe")) return -KEY_pipe;
4656 if (strEQ(d,"print")) return KEY_print;
4659 if (strEQ(d,"printf")) return KEY_printf;
4662 if (strEQ(d,"package")) return KEY_package;
4665 if (strEQ(d,"prototype")) return KEY_prototype;
4670 if (strEQ(d,"q")) return KEY_q;
4671 if (strEQ(d,"qr")) return KEY_qr;
4672 if (strEQ(d,"qq")) return KEY_qq;
4673 if (strEQ(d,"qw")) return KEY_qw;
4674 if (strEQ(d,"qx")) return KEY_qx;
4676 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4681 if (strEQ(d,"ref")) return -KEY_ref;
4684 if (strEQ(d,"read")) return -KEY_read;
4685 if (strEQ(d,"rand")) return -KEY_rand;
4686 if (strEQ(d,"recv")) return -KEY_recv;
4687 if (strEQ(d,"redo")) return KEY_redo;
4690 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4691 if (strEQ(d,"reset")) return -KEY_reset;
4694 if (strEQ(d,"return")) return KEY_return;
4695 if (strEQ(d,"rename")) return -KEY_rename;
4696 if (strEQ(d,"rindex")) return -KEY_rindex;
4699 if (strEQ(d,"require")) return -KEY_require;
4700 if (strEQ(d,"reverse")) return -KEY_reverse;
4701 if (strEQ(d,"readdir")) return -KEY_readdir;
4704 if (strEQ(d,"readlink")) return -KEY_readlink;
4705 if (strEQ(d,"readline")) return -KEY_readline;
4706 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4709 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4715 case 0: return KEY_s;
4717 if (strEQ(d,"scalar")) return KEY_scalar;
4722 if (strEQ(d,"seek")) return -KEY_seek;
4723 if (strEQ(d,"send")) return -KEY_send;
4726 if (strEQ(d,"semop")) return -KEY_semop;
4729 if (strEQ(d,"select")) return -KEY_select;
4730 if (strEQ(d,"semctl")) return -KEY_semctl;
4731 if (strEQ(d,"semget")) return -KEY_semget;
4734 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4735 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4738 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4739 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4742 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4745 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4746 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4747 if (strEQ(d,"setservent")) return -KEY_setservent;
4750 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4751 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4758 if (strEQ(d,"shift")) return KEY_shift;
4761 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4762 if (strEQ(d,"shmget")) return -KEY_shmget;
4765 if (strEQ(d,"shmread")) return -KEY_shmread;
4768 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4769 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4774 if (strEQ(d,"sin")) return -KEY_sin;
4777 if (strEQ(d,"sleep")) return -KEY_sleep;
4780 if (strEQ(d,"sort")) return KEY_sort;
4781 if (strEQ(d,"socket")) return -KEY_socket;
4782 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4785 if (strEQ(d,"split")) return KEY_split;
4786 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4787 if (strEQ(d,"splice")) return KEY_splice;
4790 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4793 if (strEQ(d,"srand")) return -KEY_srand;
4796 if (strEQ(d,"stat")) return -KEY_stat;
4797 if (strEQ(d,"study")) return KEY_study;
4800 if (strEQ(d,"substr")) return -KEY_substr;
4801 if (strEQ(d,"sub")) return KEY_sub;
4806 if (strEQ(d,"system")) return -KEY_system;
4809 if (strEQ(d,"symlink")) return -KEY_symlink;
4810 if (strEQ(d,"syscall")) return -KEY_syscall;
4811 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4812 if (strEQ(d,"sysread")) return -KEY_sysread;
4813 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4816 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4825 if (strEQ(d,"tr")) return KEY_tr;
4828 if (strEQ(d,"tie")) return KEY_tie;
4831 if (strEQ(d,"tell")) return -KEY_tell;
4832 if (strEQ(d,"tied")) return KEY_tied;
4833 if (strEQ(d,"time")) return -KEY_time;
4836 if (strEQ(d,"times")) return -KEY_times;
4839 if (strEQ(d,"telldir")) return -KEY_telldir;
4842 if (strEQ(d,"truncate")) return -KEY_truncate;
4849 if (strEQ(d,"uc")) return -KEY_uc;
4852 if (strEQ(d,"use")) return KEY_use;
4855 if (strEQ(d,"undef")) return KEY_undef;
4856 if (strEQ(d,"until")) return KEY_until;
4857 if (strEQ(d,"untie")) return KEY_untie;
4858 if (strEQ(d,"utime")) return -KEY_utime;
4859 if (strEQ(d,"umask")) return -KEY_umask;
4862 if (strEQ(d,"unless")) return KEY_unless;
4863 if (strEQ(d,"unpack")) return -KEY_unpack;
4864 if (strEQ(d,"unlink")) return -KEY_unlink;
4867 if (strEQ(d,"unshift")) return KEY_unshift;
4868 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4873 if (strEQ(d,"values")) return -KEY_values;
4874 if (strEQ(d,"vec")) return -KEY_vec;
4879 if (strEQ(d,"warn")) return -KEY_warn;
4880 if (strEQ(d,"wait")) return -KEY_wait;
4883 if (strEQ(d,"while")) return KEY_while;
4884 if (strEQ(d,"write")) return -KEY_write;
4887 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4890 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4895 if (len == 1) return -KEY_x;
4896 if (strEQ(d,"xor")) return -KEY_xor;
4899 if (len == 1) return KEY_y;
4908 checkcomma(register char *s, char *name, char *what)
4912 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4913 dTHR; /* only for ckWARN */
4914 if (ckWARN(WARN_SYNTAX)) {
4916 for (w = s+2; *w && level; w++) {
4923 for (; *w && isSPACE(*w); w++) ;
4924 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4925 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4928 while (s < PL_bufend && isSPACE(*s))
4932 while (s < PL_bufend && isSPACE(*s))
4934 if (isIDFIRST_lazy(s)) {
4936 while (isALNUM_lazy(s))
4938 while (s < PL_bufend && isSPACE(*s))
4943 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4947 croak("No comma allowed after %s", what);
4953 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4956 HV *table = GvHV(PL_hintgv); /* ^H */
4959 bool oldcatch = CATCH_GET;
4965 yyerror("%^H is not defined");
4968 cvp = hv_fetch(table, key, strlen(key), FALSE);
4969 if (!cvp || !SvOK(*cvp)) {
4970 sprintf(buf,"$^H{%s} is not defined", key);
4974 sv_2mortal(sv); /* Parent created it permanently */
4977 pv = sv_2mortal(newSVpv(s, len));
4979 typesv = sv_2mortal(newSVpv(type, 0));
4981 typesv = &PL_sv_undef;
4983 Zero(&myop, 1, BINOP);
4984 myop.op_last = (OP *) &myop;
4985 myop.op_next = Nullop;
4986 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4988 PUSHSTACKi(PERLSI_OVERLOAD);
4991 PL_op = (OP *) &myop;
4992 if (PERLDB_SUB && PL_curstash != PL_debstash)
4993 PL_op->op_private |= OPpENTERSUB_DB;
5004 if (PL_op = pp_entersub(ARGS))
5011 CATCH_SET(oldcatch);
5015 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5018 return SvREFCNT_inc(res);
5022 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5024 register char *d = dest;
5025 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5028 croak(ident_too_long);
5029 if (isALNUM(*s)) /* UTF handled below */
5031 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5036 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5040 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5041 char *t = s + UTF8SKIP(s);
5042 while (*t & 0x80 && is_utf8_mark((U8*)t))
5044 if (d + (t - s) > e)
5045 croak(ident_too_long);
5046 Copy(s, d, t - s, char);
5059 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5066 if (PL_lex_brackets == 0)
5067 PL_lex_fakebrack = 0;
5071 e = d + destlen - 3; /* two-character token, ending NUL */
5073 while (isDIGIT(*s)) {
5075 croak(ident_too_long);
5082 croak(ident_too_long);
5083 if (isALNUM(*s)) /* UTF handled below */
5085 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5090 else if (*s == ':' && s[1] == ':') {
5094 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5095 char *t = s + UTF8SKIP(s);
5096 while (*t & 0x80 && is_utf8_mark((U8*)t))
5098 if (d + (t - s) > e)
5099 croak(ident_too_long);
5100 Copy(s, d, t - s, char);
5111 if (PL_lex_state != LEX_NORMAL)
5112 PL_lex_state = LEX_INTERPENDMAYBE;
5115 if (*s == '$' && s[1] &&
5116 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5129 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5134 if (isSPACE(s[-1])) {
5137 if (ch != ' ' && ch != '\t') {
5143 if (isIDFIRST_lazy(d)) {
5147 while (e < send && isALNUM_lazy(e) || *e == ':') {
5149 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5152 Copy(s, d, e - s, char);
5157 while (isALNUM(*s) || *s == ':')
5161 while (s < send && (*s == ' ' || *s == '\t')) s++;
5162 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5163 dTHR; /* only for ckWARN */
5164 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5165 char *brack = *s == '[' ? "[...]" : "{...}";
5166 warner(WARN_AMBIGUOUS,
5167 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5168 funny, dest, brack, funny, dest, brack);
5170 PL_lex_fakebrack = PL_lex_brackets+1;
5172 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5178 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5179 PL_lex_state = LEX_INTERPEND;
5182 if (PL_lex_state == LEX_NORMAL) {
5183 dTHR; /* only for ckWARN */
5184 if (ckWARN(WARN_AMBIGUOUS) &&
5185 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5187 warner(WARN_AMBIGUOUS,
5188 "Ambiguous use of %c{%s} resolved to %c%s",
5189 funny, dest, funny, dest);
5194 s = bracket; /* let the parser handle it */
5198 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5199 PL_lex_state = LEX_INTERPEND;
5203 void pmflag(U16 *pmfl, int ch)
5208 *pmfl |= PMf_GLOBAL;
5210 *pmfl |= PMf_CONTINUE;
5214 *pmfl |= PMf_MULTILINE;
5216 *pmfl |= PMf_SINGLELINE;
5218 *pmfl |= PMf_EXTENDED;
5222 scan_pat(char *start, I32 type)
5227 s = scan_str(start);
5230 SvREFCNT_dec(PL_lex_stuff);
5231 PL_lex_stuff = Nullsv;
5232 croak("Search pattern not terminated");
5235 pm = (PMOP*)newPMOP(type, 0);
5236 if (PL_multi_open == '?')
5237 pm->op_pmflags |= PMf_ONCE;
5239 while (*s && strchr("iomsx", *s))
5240 pmflag(&pm->op_pmflags,*s++);
5243 while (*s && strchr("iogcmsx", *s))
5244 pmflag(&pm->op_pmflags,*s++);
5246 pm->op_pmpermflags = pm->op_pmflags;
5248 PL_lex_op = (OP*)pm;
5249 yylval.ival = OP_MATCH;
5254 scan_subst(char *start)
5261 yylval.ival = OP_NULL;
5263 s = scan_str(start);
5267 SvREFCNT_dec(PL_lex_stuff);
5268 PL_lex_stuff = Nullsv;
5269 croak("Substitution pattern not terminated");
5272 if (s[-1] == PL_multi_open)
5275 first_start = PL_multi_start;
5279 SvREFCNT_dec(PL_lex_stuff);
5280 PL_lex_stuff = Nullsv;
5282 SvREFCNT_dec(PL_lex_repl);
5283 PL_lex_repl = Nullsv;
5284 croak("Substitution replacement not terminated");
5286 PL_multi_start = first_start; /* so whole substitution is taken together */
5288 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5294 else if (strchr("iogcmsx", *s))
5295 pmflag(&pm->op_pmflags,*s++);
5302 pm->op_pmflags |= PMf_EVAL;
5303 repl = newSVpv("",0);
5305 sv_catpv(repl, es ? "eval " : "do ");
5306 sv_catpvn(repl, "{ ", 2);
5307 sv_catsv(repl, PL_lex_repl);
5308 sv_catpvn(repl, " };", 2);
5309 SvCOMPILED_on(repl);
5310 SvREFCNT_dec(PL_lex_repl);
5314 pm->op_pmpermflags = pm->op_pmflags;
5315 PL_lex_op = (OP*)pm;
5316 yylval.ival = OP_SUBST;
5321 scan_trans(char *start)
5332 yylval.ival = OP_NULL;
5334 s = scan_str(start);
5337 SvREFCNT_dec(PL_lex_stuff);
5338 PL_lex_stuff = Nullsv;
5339 croak("Transliteration pattern not terminated");
5341 if (s[-1] == PL_multi_open)
5347 SvREFCNT_dec(PL_lex_stuff);
5348 PL_lex_stuff = Nullsv;
5350 SvREFCNT_dec(PL_lex_repl);
5351 PL_lex_repl = Nullsv;
5352 croak("Transliteration replacement not terminated");
5356 o = newSVOP(OP_TRANS, 0, 0);
5357 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5360 New(803,tbl,256,short);
5361 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5365 complement = del = squash = 0;
5366 while (strchr("cdsCU", *s)) {
5368 complement = OPpTRANS_COMPLEMENT;
5370 del = OPpTRANS_DELETE;
5372 squash = OPpTRANS_SQUASH;
5377 utf8 &= ~OPpTRANS_FROM_UTF;
5379 utf8 |= OPpTRANS_FROM_UTF;
5383 utf8 &= ~OPpTRANS_TO_UTF;
5385 utf8 |= OPpTRANS_TO_UTF;
5388 croak("Too many /C and /U options");
5393 o->op_private = del|squash|complement|utf8;
5396 yylval.ival = OP_TRANS;
5401 scan_heredoc(register char *s)
5405 I32 op_type = OP_SCALAR;
5412 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5416 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5419 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5420 if (*peek && strchr("`'\"",*peek)) {
5423 s = delimcpy(d, e, s, PL_bufend, term, &len);
5433 if (!isALNUM_lazy(s))
5434 deprecate("bare << to mean <<\"\"");
5435 for (; isALNUM_lazy(s); s++) {
5440 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5441 croak("Delimiter for here document is too long");
5444 len = d - PL_tokenbuf;
5445 #ifndef PERL_STRICT_CR
5446 d = strchr(s, '\r');
5450 while (s < PL_bufend) {
5456 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5465 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5470 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5471 herewas = newSVpv(s,PL_bufend-s);
5473 s--, herewas = newSVpv(s,d-s);
5474 s += SvCUR(herewas);
5476 tmpstr = NEWSV(87,79);
5477 sv_upgrade(tmpstr, SVt_PVIV);
5482 else if (term == '`') {
5483 op_type = OP_BACKTICK;
5484 SvIVX(tmpstr) = '\\';
5488 PL_multi_start = PL_curcop->cop_line;
5489 PL_multi_open = PL_multi_close = '<';
5490 term = *PL_tokenbuf;
5493 while (s < PL_bufend &&
5494 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5496 PL_curcop->cop_line++;
5498 if (s >= PL_bufend) {
5499 PL_curcop->cop_line = PL_multi_start;
5500 missingterm(PL_tokenbuf);
5502 sv_setpvn(tmpstr,d+1,s-d);
5504 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5506 sv_catpvn(herewas,s,PL_bufend-s);
5507 sv_setsv(PL_linestr,herewas);
5508 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5509 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5512 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5513 while (s >= PL_bufend) { /* multiple line string? */
5515 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5516 PL_curcop->cop_line = PL_multi_start;
5517 missingterm(PL_tokenbuf);
5519 PL_curcop->cop_line++;
5520 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5521 #ifndef PERL_STRICT_CR
5522 if (PL_bufend - PL_linestart >= 2) {
5523 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5524 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5526 PL_bufend[-2] = '\n';
5528 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5530 else if (PL_bufend[-1] == '\r')
5531 PL_bufend[-1] = '\n';
5533 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5534 PL_bufend[-1] = '\n';
5536 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5537 SV *sv = NEWSV(88,0);
5539 sv_upgrade(sv, SVt_PVMG);
5540 sv_setsv(sv,PL_linestr);
5541 av_store(GvAV(PL_curcop->cop_filegv),
5542 (I32)PL_curcop->cop_line,sv);
5544 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5547 sv_catsv(PL_linestr,herewas);
5548 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5552 sv_catsv(tmpstr,PL_linestr);
5555 PL_multi_end = PL_curcop->cop_line;
5557 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5558 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5559 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5561 SvREFCNT_dec(herewas);
5562 PL_lex_stuff = tmpstr;
5563 yylval.ival = op_type;
5568 takes: current position in input buffer
5569 returns: new position in input buffer
5570 side-effects: yylval and lex_op are set.
5575 <FH> read from filehandle
5576 <pkg::FH> read from package qualified filehandle
5577 <pkg'FH> read from package qualified filehandle
5578 <$fh> read from filehandle in $fh
5584 scan_inputsymbol(char *start)
5586 register char *s = start; /* current position in buffer */
5591 d = PL_tokenbuf; /* start of temp holding space */
5592 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5593 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5595 /* die if we didn't have space for the contents of the <>,
5599 if (len >= sizeof PL_tokenbuf)
5600 croak("Excessively long <> operator");
5602 croak("Unterminated <> operator");
5607 Remember, only scalar variables are interpreted as filehandles by
5608 this code. Anything more complex (e.g., <$fh{$num}>) will be
5609 treated as a glob() call.
5610 This code makes use of the fact that except for the $ at the front,
5611 a scalar variable and a filehandle look the same.
5613 if (*d == '$' && d[1]) d++;
5615 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5616 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5619 /* If we've tried to read what we allow filehandles to look like, and
5620 there's still text left, then it must be a glob() and not a getline.
5621 Use scan_str to pull out the stuff between the <> and treat it
5622 as nothing more than a string.
5625 if (d - PL_tokenbuf != len) {
5626 yylval.ival = OP_GLOB;
5628 s = scan_str(start);
5630 croak("Glob not terminated");
5634 /* we're in a filehandle read situation */
5637 /* turn <> into <ARGV> */
5639 (void)strcpy(d,"ARGV");
5641 /* if <$fh>, create the ops to turn the variable into a
5647 /* try to find it in the pad for this block, otherwise find
5648 add symbol table ops
5650 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5651 OP *o = newOP(OP_PADSV, 0);
5653 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5656 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5657 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5658 newUNOP(OP_RV2SV, 0,
5659 newGVOP(OP_GV, 0, gv)));
5661 PL_lex_op->op_flags |= OPf_SPECIAL;
5662 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5663 yylval.ival = OP_NULL;
5666 /* If it's none of the above, it must be a literal filehandle
5667 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5669 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5670 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5671 yylval.ival = OP_NULL;
5680 takes: start position in buffer
5681 returns: position to continue reading from buffer
5682 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5683 updates the read buffer.
5685 This subroutine pulls a string out of the input. It is called for:
5686 q single quotes q(literal text)
5687 ' single quotes 'literal text'
5688 qq double quotes qq(interpolate $here please)
5689 " double quotes "interpolate $here please"
5690 qx backticks qx(/bin/ls -l)
5691 ` backticks `/bin/ls -l`
5692 qw quote words @EXPORT_OK = qw( func() $spam )
5693 m// regexp match m/this/
5694 s/// regexp substitute s/this/that/
5695 tr/// string transliterate tr/this/that/
5696 y/// string transliterate y/this/that/
5697 ($*@) sub prototypes sub foo ($)
5698 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5700 In most of these cases (all but <>, patterns and transliterate)
5701 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5702 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5703 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5706 It skips whitespace before the string starts, and treats the first
5707 character as the delimiter. If the delimiter is one of ([{< then
5708 the corresponding "close" character )]}> is used as the closing
5709 delimiter. It allows quoting of delimiters, and if the string has
5710 balanced delimiters ([{<>}]) it allows nesting.
5712 The lexer always reads these strings into lex_stuff, except in the
5713 case of the operators which take *two* arguments (s/// and tr///)
5714 when it checks to see if lex_stuff is full (presumably with the 1st
5715 arg to s or tr) and if so puts the string into lex_repl.
5720 scan_str(char *start)
5723 SV *sv; /* scalar value: string */
5724 char *tmps; /* temp string, used for delimiter matching */
5725 register char *s = start; /* current position in the buffer */
5726 register char term; /* terminating character */
5727 register char *to; /* current position in the sv's data */
5728 I32 brackets = 1; /* bracket nesting level */
5730 /* skip space before the delimiter */
5734 /* mark where we are, in case we need to report errors */
5737 /* after skipping whitespace, the next character is the terminator */
5739 /* mark where we are */
5740 PL_multi_start = PL_curcop->cop_line;
5741 PL_multi_open = term;
5743 /* find corresponding closing delimiter */
5744 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5746 PL_multi_close = term;
5748 /* create a new SV to hold the contents. 87 is leak category, I'm
5749 assuming. 79 is the SV's initial length. What a random number. */
5751 sv_upgrade(sv, SVt_PVIV);
5753 (void)SvPOK_only(sv); /* validate pointer */
5755 /* move past delimiter and try to read a complete string */
5758 /* extend sv if need be */
5759 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5760 /* set 'to' to the next character in the sv's string */
5761 to = SvPVX(sv)+SvCUR(sv);
5763 /* if open delimiter is the close delimiter read unbridle */
5764 if (PL_multi_open == PL_multi_close) {
5765 for (; s < PL_bufend; s++,to++) {
5766 /* embedded newlines increment the current line number */
5767 if (*s == '\n' && !PL_rsfp)
5768 PL_curcop->cop_line++;
5769 /* handle quoted delimiters */
5770 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5773 /* any other quotes are simply copied straight through */
5777 /* terminate when run out of buffer (the for() condition), or
5778 have found the terminator */
5779 else if (*s == term)
5785 /* if the terminator isn't the same as the start character (e.g.,
5786 matched brackets), we have to allow more in the quoting, and
5787 be prepared for nested brackets.
5790 /* read until we run out of string, or we find the terminator */
5791 for (; s < PL_bufend; s++,to++) {
5792 /* embedded newlines increment the line count */
5793 if (*s == '\n' && !PL_rsfp)
5794 PL_curcop->cop_line++;
5795 /* backslashes can escape the open or closing characters */
5796 if (*s == '\\' && s+1 < PL_bufend) {
5797 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5802 /* allow nested opens and closes */
5803 else if (*s == PL_multi_close && --brackets <= 0)
5805 else if (*s == PL_multi_open)
5810 /* terminate the copied string and update the sv's end-of-string */
5812 SvCUR_set(sv, to - SvPVX(sv));
5815 * this next chunk reads more into the buffer if we're not done yet
5818 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5820 #ifndef PERL_STRICT_CR
5821 if (to - SvPVX(sv) >= 2) {
5822 if ((to[-2] == '\r' && to[-1] == '\n') ||
5823 (to[-2] == '\n' && to[-1] == '\r'))
5827 SvCUR_set(sv, to - SvPVX(sv));
5829 else if (to[-1] == '\r')
5832 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5836 /* if we're out of file, or a read fails, bail and reset the current
5837 line marker so we can report where the unterminated string began
5840 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5842 PL_curcop->cop_line = PL_multi_start;
5845 /* we read a line, so increment our line counter */
5846 PL_curcop->cop_line++;
5848 /* update debugger info */
5849 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5850 SV *sv = NEWSV(88,0);
5852 sv_upgrade(sv, SVt_PVMG);
5853 sv_setsv(sv,PL_linestr);
5854 av_store(GvAV(PL_curcop->cop_filegv),
5855 (I32)PL_curcop->cop_line, sv);
5858 /* having changed the buffer, we must update PL_bufend */
5859 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5862 /* at this point, we have successfully read the delimited string */
5864 PL_multi_end = PL_curcop->cop_line;
5867 /* if we allocated too much space, give some back */
5868 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5869 SvLEN_set(sv, SvCUR(sv) + 1);
5870 Renew(SvPVX(sv), SvLEN(sv), char);
5873 /* decide whether this is the first or second quoted string we've read
5886 takes: pointer to position in buffer
5887 returns: pointer to new position in buffer
5888 side-effects: builds ops for the constant in yylval.op
5890 Read a number in any of the formats that Perl accepts:
5892 0(x[0-7A-F]+)|([0-7]+)
5893 [\d_]+(\.[\d_]*)?[Ee](\d+)
5895 Underbars (_) are allowed in decimal numbers. If -w is on,
5896 underbars before a decimal point must be at three digit intervals.
5898 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5901 If it reads a number without a decimal point or an exponent, it will
5902 try converting the number to an integer and see if it can do so
5903 without loss of precision.
5907 scan_num(char *start)
5909 register char *s = start; /* current position in buffer */
5910 register char *d; /* destination in temp buffer */
5911 register char *e; /* end of temp buffer */
5912 I32 tryiv; /* used to see if it can be an int */
5913 double value; /* number read, as a double */
5914 SV *sv; /* place to put the converted number */
5915 I32 floatit; /* boolean: int or float? */
5916 char *lastub = 0; /* position of last underbar */
5917 static char number_too_long[] = "Number too long";
5919 /* We use the first character to decide what type of number this is */
5923 croak("panic: scan_num");
5925 /* if it starts with a 0, it could be an octal number, a decimal in
5926 0.13 disguise, or a hexadecimal number.
5931 u holds the "number so far"
5932 shift the power of 2 of the base (hex == 4, octal == 3)
5933 overflowed was the number more than we can hold?
5935 Shift is used when we add a digit. It also serves as an "are
5936 we in octal or hex?" indicator to disallow hex characters when
5941 bool overflowed = FALSE;
5948 /* check for a decimal in disguise */
5949 else if (s[1] == '.')
5951 /* so it must be octal */
5956 /* read the rest of the octal number */
5958 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5962 /* if we don't mention it, we're done */
5971 /* 8 and 9 are not octal */
5974 yyerror("Illegal octal digit");
5978 case '0': case '1': case '2': case '3': case '4':
5979 case '5': case '6': case '7':
5980 b = *s++ & 15; /* ASCII digit -> value of digit */
5984 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5985 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5986 /* make sure they said 0x */
5991 /* Prepare to put the digit we have onto the end
5992 of the number so far. We check for overflows.
5996 n = u << shift; /* make room for the digit */
5997 if (!overflowed && (n >> shift) != u
5998 && !(PL_hints & HINT_NEW_BINARY)) {
5999 warn("Integer overflow in %s number",
6000 (shift == 4) ? "hex" : "octal");
6003 u = n | b; /* add the digit to the end */
6008 /* if we get here, we had success: make a scalar value from
6014 if ( PL_hints & HINT_NEW_BINARY)
6015 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6020 handle decimal numbers.
6021 we're also sent here when we read a 0 as the first digit
6023 case '1': case '2': case '3': case '4': case '5':
6024 case '6': case '7': case '8': case '9': case '.':
6027 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6030 /* read next group of digits and _ and copy into d */
6031 while (isDIGIT(*s) || *s == '_') {
6032 /* skip underscores, checking for misplaced ones
6036 dTHR; /* only for ckWARN */
6037 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6038 warner(WARN_SYNTAX, "Misplaced _ in number");
6042 /* check for end of fixed-length buffer */
6044 croak(number_too_long);
6045 /* if we're ok, copy the character */
6050 /* final misplaced underbar check */
6051 if (lastub && s - lastub != 3) {
6053 if (ckWARN(WARN_SYNTAX))
6054 warner(WARN_SYNTAX, "Misplaced _ in number");
6057 /* read a decimal portion if there is one. avoid
6058 3..5 being interpreted as the number 3. followed
6061 if (*s == '.' && s[1] != '.') {
6065 /* copy, ignoring underbars, until we run out of
6066 digits. Note: no misplaced underbar checks!
6068 for (; isDIGIT(*s) || *s == '_'; s++) {
6069 /* fixed length buffer check */
6071 croak(number_too_long);
6077 /* read exponent part, if present */
6078 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6082 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6083 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6085 /* allow positive or negative exponent */
6086 if (*s == '+' || *s == '-')
6089 /* read digits of exponent (no underbars :-) */
6090 while (isDIGIT(*s)) {
6092 croak(number_too_long);
6097 /* terminate the string */
6100 /* make an sv from the string */
6102 /* reset numeric locale in case we were earlier left in Swaziland */
6103 SET_NUMERIC_STANDARD();
6104 value = atof(PL_tokenbuf);
6107 See if we can make do with an integer value without loss of
6108 precision. We use I_V to cast to an int, because some
6109 compilers have issues. Then we try casting it back and see
6110 if it was the same. We only do this if we know we
6111 specifically read an integer.
6113 Note: if floatit is true, then we don't need to do the
6117 if (!floatit && (double)tryiv == value)
6118 sv_setiv(sv, tryiv);
6120 sv_setnv(sv, value);
6121 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6122 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6123 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6127 /* make the op for the constant and return */
6129 yylval.opval = newSVOP(OP_CONST, 0, sv);
6135 scan_formline(register char *s)
6140 SV *stuff = newSVpv("",0);
6141 bool needargs = FALSE;
6144 if (*s == '.' || *s == '}') {
6146 #ifdef PERL_STRICT_CR
6147 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6149 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6151 if (*t == '\n' || t == PL_bufend)
6154 if (PL_in_eval && !PL_rsfp) {
6155 eol = strchr(s,'\n');
6160 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6162 for (t = s; t < eol; t++) {
6163 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6165 goto enough; /* ~~ must be first line in formline */
6167 if (*t == '@' || *t == '^')
6170 sv_catpvn(stuff, s, eol-s);
6174 s = filter_gets(PL_linestr, PL_rsfp, 0);
6175 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6176 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6179 yyerror("Format not terminated");
6189 PL_lex_state = LEX_NORMAL;
6190 PL_nextval[PL_nexttoke].ival = 0;
6194 PL_lex_state = LEX_FORMLINE;
6195 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6197 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6201 SvREFCNT_dec(stuff);
6202 PL_lex_formbrack = 0;
6213 PL_cshlen = strlen(PL_cshname);
6218 start_subparse(I32 is_format, U32 flags)
6221 I32 oldsavestack_ix = PL_savestack_ix;
6222 CV* outsidecv = PL_compcv;
6226 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6228 save_I32(&PL_subline);
6229 save_item(PL_subname);
6231 SAVESPTR(PL_curpad);
6232 SAVESPTR(PL_comppad);
6233 SAVESPTR(PL_comppad_name);
6234 SAVESPTR(PL_compcv);
6235 SAVEI32(PL_comppad_name_fill);
6236 SAVEI32(PL_min_intro_pending);
6237 SAVEI32(PL_max_intro_pending);
6238 SAVEI32(PL_pad_reset_pending);
6240 PL_compcv = (CV*)NEWSV(1104,0);
6241 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6242 CvFLAGS(PL_compcv) |= flags;
6244 PL_comppad = newAV();
6245 av_push(PL_comppad, Nullsv);
6246 PL_curpad = AvARRAY(PL_comppad);
6247 PL_comppad_name = newAV();
6248 PL_comppad_name_fill = 0;
6249 PL_min_intro_pending = 0;
6251 PL_subline = PL_curcop->cop_line;
6253 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6254 PL_curpad[0] = (SV*)newAV();
6255 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6256 #endif /* USE_THREADS */
6258 comppadlist = newAV();
6259 AvREAL_off(comppadlist);
6260 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6261 av_store(comppadlist, 1, (SV*)PL_comppad);
6263 CvPADLIST(PL_compcv) = comppadlist;
6264 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6266 CvOWNER(PL_compcv) = 0;
6267 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6268 MUTEX_INIT(CvMUTEXP(PL_compcv));
6269 #endif /* USE_THREADS */
6271 return oldsavestack_ix;
6290 char *context = NULL;
6294 if (!yychar || (yychar == ';' && !PL_rsfp))
6296 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6297 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6298 while (isSPACE(*PL_oldoldbufptr))
6300 context = PL_oldoldbufptr;
6301 contlen = PL_bufptr - PL_oldoldbufptr;
6303 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6304 PL_oldbufptr != PL_bufptr) {
6305 while (isSPACE(*PL_oldbufptr))
6307 context = PL_oldbufptr;
6308 contlen = PL_bufptr - PL_oldbufptr;
6310 else if (yychar > 255)
6311 where = "next token ???";
6312 else if ((yychar & 127) == 127) {
6313 if (PL_lex_state == LEX_NORMAL ||
6314 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6315 where = "at end of line";
6316 else if (PL_lex_inpat)
6317 where = "within pattern";
6319 where = "within string";
6322 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6324 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6325 else if (isPRINT_LC(yychar))
6326 sv_catpvf(where_sv, "%c", yychar);
6328 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6329 where = SvPVX(where_sv);
6331 msg = sv_2mortal(newSVpv(s, 0));
6332 sv_catpvf(msg, " at %_ line %ld, ",
6333 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6335 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6337 sv_catpvf(msg, "%s\n", where);
6338 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6340 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6341 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6346 else if (PL_in_eval)
6347 sv_catsv(ERRSV, msg);
6349 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6350 if (++PL_error_count >= 10)
6351 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6353 PL_in_my_stash = Nullhv;