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 */
1457 warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1459 av_unshift(PL_rsfp_filters, 1);
1460 av_store(PL_rsfp_filters, 0, datasv) ;
1465 /* Delete most recently added instance of this filter function. */
1467 filter_del(filter_t funcp)
1470 warn("filter_del func %p", funcp);
1471 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1473 /* if filter is on top of stack (usual case) just pop it off */
1474 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1475 sv_free(av_pop(PL_rsfp_filters));
1479 /* we need to search for the correct entry and clear it */
1480 die("filter_del can only delete in reverse order (currently)");
1484 /* Invoke the n'th filter function for the current rsfp. */
1486 filter_read(int idx, SV *buf_sv, int maxlen)
1489 /* 0 = read one text line */
1494 if (!PL_rsfp_filters)
1496 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1497 /* Provide a default input filter to make life easy. */
1498 /* Note that we append to the line. This is handy. */
1500 warn("filter_read %d: from rsfp\n", idx);
1504 int old_len = SvCUR(buf_sv) ;
1506 /* ensure buf_sv is large enough */
1507 SvGROW(buf_sv, old_len + maxlen) ;
1508 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1509 if (PerlIO_error(PL_rsfp))
1510 return -1; /* error */
1512 return 0 ; /* end of file */
1514 SvCUR_set(buf_sv, old_len + len) ;
1517 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1518 if (PerlIO_error(PL_rsfp))
1519 return -1; /* error */
1521 return 0 ; /* end of file */
1524 return SvCUR(buf_sv);
1526 /* Skip this filter slot if filter has been deleted */
1527 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1529 warn("filter_read %d: skipped (filter deleted)\n", idx);
1530 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1532 /* Get function pointer hidden within datasv */
1533 funcp = (filter_t)IoDIRP(datasv);
1536 warn("filter_read %d: via function %p (%s)\n",
1537 idx, funcp, SvPV(datasv,n_a));
1539 /* Call function. The function is expected to */
1540 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1541 /* Return: <0:error, =0:eof, >0:not eof */
1542 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1546 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1549 if (!PL_rsfp_filters) {
1550 filter_add(win32_textfilter,NULL);
1553 if (PL_rsfp_filters) {
1556 SvCUR_set(sv, 0); /* start with empty line */
1557 if (FILTER_READ(0, sv, 0) > 0)
1558 return ( SvPVX(sv) ) ;
1563 return (sv_gets(sv, fp, append));
1568 static char* exp_name[] =
1569 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1575 Works out what to call the token just pulled out of the input
1576 stream. The yacc parser takes care of taking the ops we return and
1577 stitching them into a tree.
1583 if read an identifier
1584 if we're in a my declaration
1585 croak if they tried to say my($foo::bar)
1586 build the ops for a my() declaration
1587 if it's an access to a my() variable
1588 are we in a sort block?
1589 croak if my($a); $a <=> $b
1590 build ops for access to a my() variable
1591 if in a dq string, and they've said @foo and we can't find @foo
1593 build ops for a bareword
1594 if we already built the token before, use it.
1597 int yylex(PERL_YYLEX_PARAM_DECL)
1607 #ifdef USE_PURE_BISON
1608 yylval_pointer = lvalp;
1609 yychar_pointer = lcharp;
1612 /* check if there's an identifier for us to look at */
1613 if (PL_pending_ident) {
1614 /* pit holds the identifier we read and pending_ident is reset */
1615 char pit = PL_pending_ident;
1616 PL_pending_ident = 0;
1618 /* if we're in a my(), we can't allow dynamics here.
1619 $foo'bar has already been turned into $foo::bar, so
1620 just check for colons.
1622 if it's a legal name, the OP is a PADANY.
1625 if (strchr(PL_tokenbuf,':'))
1626 croak(PL_no_myglob,PL_tokenbuf);
1628 yylval.opval = newOP(OP_PADANY, 0);
1629 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1634 build the ops for accesses to a my() variable.
1636 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1637 then used in a comparison. This catches most, but not
1638 all cases. For instance, it catches
1639 sort { my($a); $a <=> $b }
1641 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1642 (although why you'd do that is anyone's guess).
1645 if (!strchr(PL_tokenbuf,':')) {
1647 /* Check for single character per-thread SVs */
1648 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1649 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1650 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1652 yylval.opval = newOP(OP_THREADSV, 0);
1653 yylval.opval->op_targ = tmp;
1656 #endif /* USE_THREADS */
1657 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1658 /* if it's a sort block and they're naming $a or $b */
1659 if (PL_last_lop_op == OP_SORT &&
1660 PL_tokenbuf[0] == '$' &&
1661 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1664 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1665 d < PL_bufend && *d != '\n';
1668 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1669 croak("Can't use \"my %s\" in sort comparison",
1675 yylval.opval = newOP(OP_PADANY, 0);
1676 yylval.opval->op_targ = tmp;
1682 Whine if they've said @foo in a doublequoted string,
1683 and @foo isn't a variable we can find in the symbol
1686 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1687 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1688 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1689 yyerror(form("In string, %s now must be written as \\%s",
1690 PL_tokenbuf, PL_tokenbuf));
1693 /* build ops for a bareword */
1694 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1695 yylval.opval->op_private = OPpCONST_ENTERED;
1696 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1697 ((PL_tokenbuf[0] == '$') ? SVt_PV
1698 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1703 /* no identifier pending identification */
1705 switch (PL_lex_state) {
1707 case LEX_NORMAL: /* Some compilers will produce faster */
1708 case LEX_INTERPNORMAL: /* code if we comment these out. */
1712 /* when we're already built the next token, just pull it out the queue */
1715 yylval = PL_nextval[PL_nexttoke];
1717 PL_lex_state = PL_lex_defer;
1718 PL_expect = PL_lex_expect;
1719 PL_lex_defer = LEX_NORMAL;
1721 return(PL_nexttype[PL_nexttoke]);
1723 /* interpolated case modifiers like \L \U, including \Q and \E.
1724 when we get here, PL_bufptr is at the \
1726 case LEX_INTERPCASEMOD:
1728 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1729 croak("panic: INTERPCASEMOD");
1731 /* handle \E or end of string */
1732 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1736 if (PL_lex_casemods) {
1737 oldmod = PL_lex_casestack[--PL_lex_casemods];
1738 PL_lex_casestack[PL_lex_casemods] = '\0';
1740 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1742 PL_lex_state = LEX_INTERPCONCAT;
1746 if (PL_bufptr != PL_bufend)
1748 PL_lex_state = LEX_INTERPCONCAT;
1749 return yylex(PERL_YYLEX_PARAM);
1753 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1754 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1755 if (strchr("LU", *s) &&
1756 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1758 PL_lex_casestack[--PL_lex_casemods] = '\0';
1761 if (PL_lex_casemods > 10) {
1762 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1763 if (newlb != PL_lex_casestack) {
1765 PL_lex_casestack = newlb;
1768 PL_lex_casestack[PL_lex_casemods++] = *s;
1769 PL_lex_casestack[PL_lex_casemods] = '\0';
1770 PL_lex_state = LEX_INTERPCONCAT;
1771 PL_nextval[PL_nexttoke].ival = 0;
1774 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1776 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1778 PL_nextval[PL_nexttoke].ival = OP_LC;
1780 PL_nextval[PL_nexttoke].ival = OP_UC;
1782 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1784 croak("panic: yylex");
1787 if (PL_lex_starts) {
1793 return yylex(PERL_YYLEX_PARAM);
1796 case LEX_INTERPPUSH:
1797 return sublex_push();
1799 case LEX_INTERPSTART:
1800 if (PL_bufptr == PL_bufend)
1801 return sublex_done();
1803 PL_lex_dojoin = (*PL_bufptr == '@');
1804 PL_lex_state = LEX_INTERPNORMAL;
1805 if (PL_lex_dojoin) {
1806 PL_nextval[PL_nexttoke].ival = 0;
1809 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1810 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1811 force_next(PRIVATEREF);
1813 force_ident("\"", '$');
1814 #endif /* USE_THREADS */
1815 PL_nextval[PL_nexttoke].ival = 0;
1817 PL_nextval[PL_nexttoke].ival = 0;
1819 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1822 if (PL_lex_starts++) {
1826 return yylex(PERL_YYLEX_PARAM);
1828 case LEX_INTERPENDMAYBE:
1829 if (intuit_more(PL_bufptr)) {
1830 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1836 if (PL_lex_dojoin) {
1837 PL_lex_dojoin = FALSE;
1838 PL_lex_state = LEX_INTERPCONCAT;
1842 case LEX_INTERPCONCAT:
1844 if (PL_lex_brackets)
1845 croak("panic: INTERPCONCAT");
1847 if (PL_bufptr == PL_bufend)
1848 return sublex_done();
1850 if (SvIVX(PL_linestr) == '\'') {
1851 SV *sv = newSVsv(PL_linestr);
1854 else if ( PL_hints & HINT_NEW_RE )
1855 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1856 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1860 s = scan_const(PL_bufptr);
1862 PL_lex_state = LEX_INTERPCASEMOD;
1864 PL_lex_state = LEX_INTERPSTART;
1867 if (s != PL_bufptr) {
1868 PL_nextval[PL_nexttoke] = yylval;
1871 if (PL_lex_starts++)
1875 return yylex(PERL_YYLEX_PARAM);
1879 return yylex(PERL_YYLEX_PARAM);
1881 PL_lex_state = LEX_NORMAL;
1882 s = scan_formline(PL_bufptr);
1883 if (!PL_lex_formbrack)
1889 PL_oldoldbufptr = PL_oldbufptr;
1892 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1898 if (isIDFIRST_lazy(s))
1900 croak("Unrecognized character \\x%02X", *s & 255);
1903 goto fake_eof; /* emulate EOF on ^D or ^Z */
1908 if (PL_lex_brackets)
1909 yyerror("Missing right bracket");
1912 if (s++ < PL_bufend)
1913 goto retry; /* ignore stray nulls */
1916 if (!PL_in_eval && !PL_preambled) {
1917 PL_preambled = TRUE;
1918 sv_setpv(PL_linestr,incl_perldb());
1919 if (SvCUR(PL_linestr))
1920 sv_catpv(PL_linestr,";");
1922 while(AvFILLp(PL_preambleav) >= 0) {
1923 SV *tmpsv = av_shift(PL_preambleav);
1924 sv_catsv(PL_linestr, tmpsv);
1925 sv_catpv(PL_linestr, ";");
1928 sv_free((SV*)PL_preambleav);
1929 PL_preambleav = NULL;
1931 if (PL_minus_n || PL_minus_p) {
1932 sv_catpv(PL_linestr, "LINE: while (<>) {");
1934 sv_catpv(PL_linestr,"chomp;");
1936 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1938 GvIMPORTED_AV_on(gv);
1940 if (strchr("/'\"", *PL_splitstr)
1941 && strchr(PL_splitstr + 1, *PL_splitstr))
1942 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1945 s = "'~#\200\1'"; /* surely one char is unused...*/
1946 while (s[1] && strchr(PL_splitstr, *s)) s++;
1948 sv_catpvf(PL_linestr, "@F=split(%s%c",
1949 "q" + (delim == '\''), delim);
1950 for (s = PL_splitstr; *s; s++) {
1952 sv_catpvn(PL_linestr, "\\", 1);
1953 sv_catpvn(PL_linestr, s, 1);
1955 sv_catpvf(PL_linestr, "%c);", delim);
1959 sv_catpv(PL_linestr,"@F=split(' ');");
1962 sv_catpv(PL_linestr, "\n");
1963 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1964 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1965 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1966 SV *sv = NEWSV(85,0);
1968 sv_upgrade(sv, SVt_PVMG);
1969 sv_setsv(sv,PL_linestr);
1970 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1975 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1978 if (PL_preprocess && !PL_in_eval)
1979 (void)PerlProc_pclose(PL_rsfp);
1980 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1981 PerlIO_clearerr(PL_rsfp);
1983 (void)PerlIO_close(PL_rsfp);
1985 PL_doextract = FALSE;
1987 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1988 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1989 sv_catpv(PL_linestr,";}");
1990 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1991 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1992 PL_minus_n = PL_minus_p = 0;
1995 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1996 sv_setpv(PL_linestr,"");
1997 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2000 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2001 PL_doextract = FALSE;
2003 /* Incest with pod. */
2004 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2005 sv_setpv(PL_linestr, "");
2006 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2007 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2008 PL_doextract = FALSE;
2012 } while (PL_doextract);
2013 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2014 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2015 SV *sv = NEWSV(85,0);
2017 sv_upgrade(sv, SVt_PVMG);
2018 sv_setsv(sv,PL_linestr);
2019 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2021 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2022 if (PL_curcop->cop_line == 1) {
2023 while (s < PL_bufend && isSPACE(*s))
2025 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2029 if (*s == '#' && *(s+1) == '!')
2031 #ifdef ALTERNATE_SHEBANG
2033 static char as[] = ALTERNATE_SHEBANG;
2034 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2035 d = s + (sizeof(as) - 1);
2037 #endif /* ALTERNATE_SHEBANG */
2046 while (*d && !isSPACE(*d))
2050 #ifdef ARG_ZERO_IS_SCRIPT
2051 if (ipathend > ipath) {
2053 * HP-UX (at least) sets argv[0] to the script name,
2054 * which makes $^X incorrect. And Digital UNIX and Linux,
2055 * at least, set argv[0] to the basename of the Perl
2056 * interpreter. So, having found "#!", we'll set it right.
2058 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2059 assert(SvPOK(x) || SvGMAGICAL(x));
2060 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2061 sv_setpvn(x, ipath, ipathend - ipath);
2064 TAINT_NOT; /* $^X is always tainted, but that's OK */
2066 #endif /* ARG_ZERO_IS_SCRIPT */
2071 d = instr(s,"perl -");
2073 d = instr(s,"perl");
2074 #ifdef ALTERNATE_SHEBANG
2076 * If the ALTERNATE_SHEBANG on this system starts with a
2077 * character that can be part of a Perl expression, then if
2078 * we see it but not "perl", we're probably looking at the
2079 * start of Perl code, not a request to hand off to some
2080 * other interpreter. Similarly, if "perl" is there, but
2081 * not in the first 'word' of the line, we assume the line
2082 * contains the start of the Perl program.
2084 if (d && *s != '#') {
2086 while (*c && !strchr("; \t\r\n\f\v#", *c))
2089 d = Nullch; /* "perl" not in first word; ignore */
2091 *s = '#'; /* Don't try to parse shebang line */
2093 #endif /* ALTERNATE_SHEBANG */
2098 !instr(s,"indir") &&
2099 instr(PL_origargv[0],"perl"))
2105 while (s < PL_bufend && isSPACE(*s))
2107 if (s < PL_bufend) {
2108 Newz(899,newargv,PL_origargc+3,char*);
2110 while (s < PL_bufend && !isSPACE(*s))
2113 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2116 newargv = PL_origargv;
2118 execv(ipath, newargv);
2119 croak("Can't exec %s", ipath);
2122 U32 oldpdb = PL_perldb;
2123 bool oldn = PL_minus_n;
2124 bool oldp = PL_minus_p;
2126 while (*d && !isSPACE(*d)) d++;
2127 while (*d == ' ' || *d == '\t') d++;
2131 if (*d == 'M' || *d == 'm') {
2133 while (*d && !isSPACE(*d)) d++;
2134 croak("Too late for \"-%.*s\" option",
2137 d = moreswitches(d);
2139 if (PERLDB_LINE && !oldpdb ||
2140 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2141 /* if we have already added "LINE: while (<>) {",
2142 we must not do it again */
2144 sv_setpv(PL_linestr, "");
2145 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2146 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2147 PL_preambled = FALSE;
2149 (void)gv_fetchfile(PL_origfilename);
2156 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2158 PL_lex_state = LEX_FORMLINE;
2159 return yylex(PERL_YYLEX_PARAM);
2163 #ifdef PERL_STRICT_CR
2164 warn("Illegal character \\%03o (carriage return)", '\r');
2166 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2168 case ' ': case '\t': case '\f': case 013:
2173 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2175 while (s < d && *s != '\n')
2180 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2182 PL_lex_state = LEX_FORMLINE;
2183 return yylex(PERL_YYLEX_PARAM);
2192 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2197 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2200 if (strnEQ(s,"=>",2)) {
2201 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2202 OPERATOR('-'); /* unary minus */
2204 PL_last_uni = PL_oldbufptr;
2205 PL_last_lop_op = OP_FTEREAD; /* good enough */
2207 case 'r': FTST(OP_FTEREAD);
2208 case 'w': FTST(OP_FTEWRITE);
2209 case 'x': FTST(OP_FTEEXEC);
2210 case 'o': FTST(OP_FTEOWNED);
2211 case 'R': FTST(OP_FTRREAD);
2212 case 'W': FTST(OP_FTRWRITE);
2213 case 'X': FTST(OP_FTREXEC);
2214 case 'O': FTST(OP_FTROWNED);
2215 case 'e': FTST(OP_FTIS);
2216 case 'z': FTST(OP_FTZERO);
2217 case 's': FTST(OP_FTSIZE);
2218 case 'f': FTST(OP_FTFILE);
2219 case 'd': FTST(OP_FTDIR);
2220 case 'l': FTST(OP_FTLINK);
2221 case 'p': FTST(OP_FTPIPE);
2222 case 'S': FTST(OP_FTSOCK);
2223 case 'u': FTST(OP_FTSUID);
2224 case 'g': FTST(OP_FTSGID);
2225 case 'k': FTST(OP_FTSVTX);
2226 case 'b': FTST(OP_FTBLK);
2227 case 'c': FTST(OP_FTCHR);
2228 case 't': FTST(OP_FTTTY);
2229 case 'T': FTST(OP_FTTEXT);
2230 case 'B': FTST(OP_FTBINARY);
2231 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2232 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2233 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2235 croak("Unrecognized file test: -%c", (int)tmp);
2242 if (PL_expect == XOPERATOR)
2247 else if (*s == '>') {
2250 if (isIDFIRST_lazy(s)) {
2251 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2259 if (PL_expect == XOPERATOR)
2262 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2264 OPERATOR('-'); /* unary minus */
2271 if (PL_expect == XOPERATOR)
2276 if (PL_expect == XOPERATOR)
2279 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2285 if (PL_expect != XOPERATOR) {
2286 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2287 PL_expect = XOPERATOR;
2288 force_ident(PL_tokenbuf, '*');
2301 if (PL_expect == XOPERATOR) {
2305 PL_tokenbuf[0] = '%';
2306 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2307 if (!PL_tokenbuf[1]) {
2309 yyerror("Final % should be \\% or %name");
2312 PL_pending_ident = '%';
2334 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2335 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2340 if (PL_curcop->cop_line < PL_copline)
2341 PL_copline = PL_curcop->cop_line;
2352 if (PL_lex_brackets <= 0)
2353 yyerror("Unmatched right bracket");
2356 if (PL_lex_state == LEX_INTERPNORMAL) {
2357 if (PL_lex_brackets == 0) {
2358 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2359 PL_lex_state = LEX_INTERPEND;
2366 if (PL_lex_brackets > 100) {
2367 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2368 if (newlb != PL_lex_brackstack) {
2370 PL_lex_brackstack = newlb;
2373 switch (PL_expect) {
2375 if (PL_lex_formbrack) {
2379 if (PL_oldoldbufptr == PL_last_lop)
2380 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2382 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2383 OPERATOR(HASHBRACK);
2385 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2388 PL_tokenbuf[0] = '\0';
2389 if (d < PL_bufend && *d == '-') {
2390 PL_tokenbuf[0] = '-';
2392 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2395 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2396 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2398 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2401 char minus = (PL_tokenbuf[0] == '-');
2402 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2409 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2413 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2418 if (PL_oldoldbufptr == PL_last_lop)
2419 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2421 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2424 OPERATOR(HASHBRACK);
2425 /* This hack serves to disambiguate a pair of curlies
2426 * as being a block or an anon hash. Normally, expectation
2427 * determines that, but in cases where we're not in a
2428 * position to expect anything in particular (like inside
2429 * eval"") we have to resolve the ambiguity. This code
2430 * covers the case where the first term in the curlies is a
2431 * quoted string. Most other cases need to be explicitly
2432 * disambiguated by prepending a `+' before the opening
2433 * curly in order to force resolution as an anon hash.
2435 * XXX should probably propagate the outer expectation
2436 * into eval"" to rely less on this hack, but that could
2437 * potentially break current behavior of eval"".
2441 if (*s == '\'' || *s == '"' || *s == '`') {
2442 /* common case: get past first string, handling escapes */
2443 for (t++; t < PL_bufend && *t != *s;)
2444 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2448 else if (*s == 'q') {
2451 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2452 && !isALNUM(*t)))) {
2454 char open, close, term;
2457 while (t < PL_bufend && isSPACE(*t))
2461 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2465 for (t++; t < PL_bufend; t++) {
2466 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2468 else if (*t == open)
2472 for (t++; t < PL_bufend; t++) {
2473 if (*t == '\\' && t+1 < PL_bufend)
2475 else if (*t == close && --brackets <= 0)
2477 else if (*t == open)
2483 else if (isIDFIRST_lazy(s)) {
2484 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2486 while (t < PL_bufend && isSPACE(*t))
2488 /* if comma follows first term, call it an anon hash */
2489 /* XXX it could be a comma expression with loop modifiers */
2490 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2491 || (*t == '=' && t[1] == '>')))
2492 OPERATOR(HASHBRACK);
2493 if (PL_expect == XREF)
2494 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2496 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2502 yylval.ival = PL_curcop->cop_line;
2503 if (isSPACE(*s) || *s == '#')
2504 PL_copline = NOLINE; /* invalidate current command line number */
2509 if (PL_lex_brackets <= 0)
2510 yyerror("Unmatched right bracket");
2512 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2513 if (PL_lex_brackets < PL_lex_formbrack)
2514 PL_lex_formbrack = 0;
2515 if (PL_lex_state == LEX_INTERPNORMAL) {
2516 if (PL_lex_brackets == 0) {
2517 if (PL_lex_fakebrack) {
2518 PL_lex_state = LEX_INTERPEND;
2520 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2522 if (*s == '-' && s[1] == '>')
2523 PL_lex_state = LEX_INTERPENDMAYBE;
2524 else if (*s != '[' && *s != '{')
2525 PL_lex_state = LEX_INTERPEND;
2528 if (PL_lex_brackets < PL_lex_fakebrack) {
2530 PL_lex_fakebrack = 0;
2531 return yylex(PERL_YYLEX_PARAM); /* ignore fake brackets */
2541 if (PL_expect == XOPERATOR) {
2542 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2543 PL_curcop->cop_line--;
2544 warner(WARN_SEMICOLON, PL_warn_nosemi);
2545 PL_curcop->cop_line++;
2550 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2552 PL_expect = XOPERATOR;
2553 force_ident(PL_tokenbuf, '&');
2557 yylval.ival = (OPpENTERSUB_AMPER<<8);
2576 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2577 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2579 if (PL_expect == XSTATE && isALPHA(tmp) &&
2580 (s == PL_linestart+1 || s[-2] == '\n') )
2582 if (PL_in_eval && !PL_rsfp) {
2587 if (strnEQ(s,"=cut",4)) {
2601 PL_doextract = TRUE;
2604 if (PL_lex_brackets < PL_lex_formbrack) {
2606 #ifdef PERL_STRICT_CR
2607 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2609 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2611 if (*t == '\n' || *t == '#') {
2629 if (PL_expect != XOPERATOR) {
2630 if (s[1] != '<' && !strchr(s,'>'))
2633 s = scan_heredoc(s);
2635 s = scan_inputsymbol(s);
2636 TERM(sublex_start());
2641 SHop(OP_LEFT_SHIFT);
2655 SHop(OP_RIGHT_SHIFT);
2664 if (PL_expect == XOPERATOR) {
2665 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2668 return ','; /* grandfather non-comma-format format */
2672 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2673 if (PL_expect == XOPERATOR)
2674 no_op("Array length", PL_bufptr);
2675 PL_tokenbuf[0] = '@';
2676 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2678 if (!PL_tokenbuf[1])
2680 PL_expect = XOPERATOR;
2681 PL_pending_ident = '#';
2685 if (PL_expect == XOPERATOR)
2686 no_op("Scalar", PL_bufptr);
2687 PL_tokenbuf[0] = '$';
2688 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2689 if (!PL_tokenbuf[1]) {
2691 yyerror("Final $ should be \\$ or $name");
2695 /* This kludge not intended to be bulletproof. */
2696 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2697 yylval.opval = newSVOP(OP_CONST, 0,
2698 newSViv((IV)PL_compiling.cop_arybase));
2699 yylval.opval->op_private = OPpCONST_ARYBASE;
2704 if (PL_lex_state == LEX_NORMAL)
2707 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2710 PL_tokenbuf[0] = '@';
2711 if (ckWARN(WARN_SYNTAX)) {
2713 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2716 PL_bufptr = skipspace(PL_bufptr);
2717 while (t < PL_bufend && *t != ']')
2720 "Multidimensional syntax %.*s not supported",
2721 (t - PL_bufptr) + 1, PL_bufptr);
2725 else if (*s == '{') {
2726 PL_tokenbuf[0] = '%';
2727 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2728 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2730 char tmpbuf[sizeof PL_tokenbuf];
2732 for (t++; isSPACE(*t); t++) ;
2733 if (isIDFIRST_lazy(t)) {
2734 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2735 for (; isSPACE(*t); t++) ;
2736 if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
2738 "You need to quote \"%s\"", tmpbuf);
2744 PL_expect = XOPERATOR;
2745 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2746 bool islop = (PL_last_lop == PL_oldoldbufptr);
2747 if (!islop || PL_last_lop_op == OP_GREPSTART)
2748 PL_expect = XOPERATOR;
2749 else if (strchr("$@\"'`q", *s))
2750 PL_expect = XTERM; /* e.g. print $fh "foo" */
2751 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2752 PL_expect = XTERM; /* e.g. print $fh &sub */
2753 else if (isIDFIRST_lazy(s)) {
2754 char tmpbuf[sizeof PL_tokenbuf];
2755 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2756 if (tmp = keyword(tmpbuf, len)) {
2757 /* binary operators exclude handle interpretations */
2769 PL_expect = XTERM; /* e.g. print $fh length() */
2774 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2775 if (gv && GvCVu(gv))
2776 PL_expect = XTERM; /* e.g. print $fh subr() */
2779 else if (isDIGIT(*s))
2780 PL_expect = XTERM; /* e.g. print $fh 3 */
2781 else if (*s == '.' && isDIGIT(s[1]))
2782 PL_expect = XTERM; /* e.g. print $fh .3 */
2783 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2784 PL_expect = XTERM; /* e.g. print $fh -1 */
2785 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2786 PL_expect = XTERM; /* print $fh <<"EOF" */
2788 PL_pending_ident = '$';
2792 if (PL_expect == XOPERATOR)
2794 PL_tokenbuf[0] = '@';
2795 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2796 if (!PL_tokenbuf[1]) {
2798 yyerror("Final @ should be \\@ or @name");
2801 if (PL_lex_state == LEX_NORMAL)
2803 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2805 PL_tokenbuf[0] = '%';
2807 /* Warn about @ where they meant $. */
2808 if (ckWARN(WARN_SYNTAX)) {
2809 if (*s == '[' || *s == '{') {
2811 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2813 if (*t == '}' || *t == ']') {
2815 PL_bufptr = skipspace(PL_bufptr);
2817 "Scalar value %.*s better written as $%.*s",
2818 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2823 PL_pending_ident = '@';
2826 case '/': /* may either be division or pattern */
2827 case '?': /* may either be conditional or pattern */
2828 if (PL_expect != XOPERATOR) {
2829 /* Disable warning on "study /blah/" */
2830 if (PL_oldoldbufptr == PL_last_uni
2831 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2832 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2834 s = scan_pat(s,OP_MATCH);
2835 TERM(sublex_start());
2843 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2844 #ifdef PERL_STRICT_CR
2847 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2849 && (s == PL_linestart || s[-1] == '\n') )
2851 PL_lex_formbrack = 0;
2855 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2861 yylval.ival = OPf_SPECIAL;
2867 if (PL_expect != XOPERATOR)
2872 case '0': case '1': case '2': case '3': case '4':
2873 case '5': case '6': case '7': case '8': case '9':
2875 if (PL_expect == XOPERATOR)
2881 if (PL_expect == XOPERATOR) {
2882 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2885 return ','; /* grandfather non-comma-format format */
2891 missingterm((char*)0);
2892 yylval.ival = OP_CONST;
2893 TERM(sublex_start());
2897 if (PL_expect == XOPERATOR) {
2898 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2901 return ','; /* grandfather non-comma-format format */
2907 missingterm((char*)0);
2908 yylval.ival = OP_CONST;
2909 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2910 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2911 yylval.ival = OP_STRINGIFY;
2915 TERM(sublex_start());
2919 if (PL_expect == XOPERATOR)
2920 no_op("Backticks",s);
2922 missingterm((char*)0);
2923 yylval.ival = OP_BACKTICK;
2925 TERM(sublex_start());
2929 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2930 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2932 if (PL_expect == XOPERATOR)
2933 no_op("Backslash",s);
2937 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2977 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2979 /* Some keywords can be followed by any delimiter, including ':' */
2980 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2981 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2982 (PL_tokenbuf[0] == 'q' &&
2983 strchr("qwxr", PL_tokenbuf[1]))));
2985 /* x::* is just a word, unless x is "CORE" */
2986 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2990 while (d < PL_bufend && isSPACE(*d))
2991 d++; /* no comments skipped here, or s### is misparsed */
2993 /* Is this a label? */
2994 if (!tmp && PL_expect == XSTATE
2995 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2997 yylval.pval = savepv(PL_tokenbuf);
3002 /* Check for keywords */
3003 tmp = keyword(PL_tokenbuf, len);
3005 /* Is this a word before a => operator? */
3006 if (strnEQ(d,"=>",2)) {
3008 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3009 yylval.opval->op_private = OPpCONST_BARE;
3013 if (tmp < 0) { /* second-class keyword? */
3014 GV *ogv = Nullgv; /* override (winner) */
3015 GV *hgv = Nullgv; /* hidden (loser) */
3016 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3018 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3021 if (GvIMPORTED_CV(gv))
3023 else if (! CvMETHOD(cv))
3027 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3028 (gv = *gvp) != (GV*)&PL_sv_undef &&
3029 GvCVu(gv) && GvIMPORTED_CV(gv))
3035 tmp = 0; /* overridden by import or by GLOBAL */
3038 && -tmp==KEY_lock /* XXX generalizable kludge */
3039 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3041 tmp = 0; /* any sub overrides "weak" keyword */
3043 else { /* no override */
3047 if (ckWARN(WARN_AMBIGUOUS) && hgv
3048 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3049 warner(WARN_AMBIGUOUS,
3050 "Ambiguous call resolved as CORE::%s(), %s",
3051 GvENAME(hgv), "qualify as such or use &");
3058 default: /* not a keyword */
3061 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3063 /* Get the rest if it looks like a package qualifier */
3065 if (*s == '\'' || *s == ':' && s[1] == ':') {
3067 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3070 croak("Bad name after %s%s", PL_tokenbuf,
3071 *s == '\'' ? "'" : "::");
3075 if (PL_expect == XOPERATOR) {
3076 if (PL_bufptr == PL_linestart) {
3077 PL_curcop->cop_line--;
3078 warner(WARN_SEMICOLON, PL_warn_nosemi);
3079 PL_curcop->cop_line++;
3082 no_op("Bareword",s);
3085 /* Look for a subroutine with this name in current package,
3086 unless name is "Foo::", in which case Foo is a bearword
3087 (and a package name). */
3090 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3092 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3094 "Bareword \"%s\" refers to nonexistent package",
3097 PL_tokenbuf[len] = '\0';
3104 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3107 /* if we saw a global override before, get the right name */
3110 sv = newSVpv("CORE::GLOBAL::",14);
3111 sv_catpv(sv,PL_tokenbuf);
3114 sv = newSVpv(PL_tokenbuf,0);
3116 /* Presume this is going to be a bareword of some sort. */
3119 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3120 yylval.opval->op_private = OPpCONST_BARE;
3122 /* And if "Foo::", then that's what it certainly is. */
3127 /* See if it's the indirect object for a list operator. */
3129 if (PL_oldoldbufptr &&
3130 PL_oldoldbufptr < PL_bufptr &&
3131 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3132 /* NO SKIPSPACE BEFORE HERE! */
3134 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3135 || (PL_last_lop_op == OP_ENTERSUB
3137 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3139 bool immediate_paren = *s == '(';
3141 /* (Now we can afford to cross potential line boundary.) */
3144 /* Two barewords in a row may indicate method call. */
3146 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3149 /* If not a declared subroutine, it's an indirect object. */
3150 /* (But it's an indir obj regardless for sort.) */
3152 if ((PL_last_lop_op == OP_SORT ||
3153 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3154 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3155 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3160 /* If followed by a paren, it's certainly a subroutine. */
3162 PL_expect = XOPERATOR;
3166 if (gv && GvCVu(gv)) {
3168 if ((cv = GvCV(gv)) && SvPOK(cv))
3169 PL_last_proto = SvPV((SV*)cv, n_a);
3170 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3171 if (*d == ')' && (sv = cv_const_sv(cv))) {
3176 PL_nextval[PL_nexttoke].opval = yylval.opval;
3177 PL_expect = XOPERATOR;
3180 PL_last_lop_op = OP_ENTERSUB;
3184 /* If followed by var or block, call it a method (unless sub) */
3186 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3187 PL_last_lop = PL_oldbufptr;
3188 PL_last_lop_op = OP_METHOD;
3192 /* If followed by a bareword, see if it looks like indir obj. */
3194 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3197 /* Not a method, so call it a subroutine (if defined) */
3199 if (gv && GvCVu(gv)) {
3201 if (lastchar == '-')
3202 warn("Ambiguous use of -%s resolved as -&%s()",
3203 PL_tokenbuf, PL_tokenbuf);
3204 PL_last_lop = PL_oldbufptr;
3205 PL_last_lop_op = OP_ENTERSUB;
3206 /* Check for a constant sub */
3208 if ((sv = cv_const_sv(cv))) {
3210 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3211 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3212 yylval.opval->op_private = 0;
3216 /* Resolve to GV now. */
3217 op_free(yylval.opval);
3218 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3219 PL_last_lop_op = OP_ENTERSUB;
3220 /* Is there a prototype? */
3223 PL_last_proto = SvPV((SV*)cv, len);
3226 if (strEQ(PL_last_proto, "$"))
3228 if (*PL_last_proto == '&' && *s == '{') {
3229 sv_setpv(PL_subname,"__ANON__");
3233 PL_last_proto = NULL;
3234 PL_nextval[PL_nexttoke].opval = yylval.opval;
3240 if (PL_hints & HINT_STRICT_SUBS &&
3243 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3244 PL_last_lop_op != OP_ACCEPT &&
3245 PL_last_lop_op != OP_PIPE_OP &&
3246 PL_last_lop_op != OP_SOCKPAIR &&
3247 !(PL_last_lop_op == OP_ENTERSUB
3249 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3252 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3257 /* Call it a bare word */
3260 if (ckWARN(WARN_RESERVED)) {
3261 if (lastchar != '-') {
3262 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3264 warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
3269 if (lastchar && strchr("*%&", lastchar)) {
3270 warn("Operator or semicolon missing before %c%s",
3271 lastchar, PL_tokenbuf);
3272 warn("Ambiguous use of %c resolved as operator %c",
3273 lastchar, lastchar);
3279 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3280 newSVsv(GvSV(PL_curcop->cop_filegv)));
3284 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3285 newSVpvf("%ld", (long)PL_curcop->cop_line));
3288 case KEY___PACKAGE__:
3289 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3291 ? newSVsv(PL_curstname)
3300 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3301 char *pname = "main";
3302 if (PL_tokenbuf[2] == 'D')
3303 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3304 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3307 GvIOp(gv) = newIO();
3308 IoIFP(GvIOp(gv)) = PL_rsfp;
3309 #if defined(HAS_FCNTL) && defined(F_SETFD)
3311 int fd = PerlIO_fileno(PL_rsfp);
3312 fcntl(fd,F_SETFD,fd >= 3);
3315 /* Mark this internal pseudo-handle as clean */
3316 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3318 IoTYPE(GvIOp(gv)) = '|';
3319 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3320 IoTYPE(GvIOp(gv)) = '-';
3322 IoTYPE(GvIOp(gv)) = '<';
3333 if (PL_expect == XSTATE) {
3340 if (*s == ':' && s[1] == ':') {
3343 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3344 tmp = keyword(PL_tokenbuf, len);
3358 LOP(OP_ACCEPT,XTERM);
3364 LOP(OP_ATAN2,XTERM);
3373 LOP(OP_BLESS,XTERM);
3382 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3399 if (!PL_cryptseen++)
3402 LOP(OP_CRYPT,XTERM);
3405 if (ckWARN(WARN_OCTAL)) {
3406 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3407 if (*d != '0' && isDIGIT(*d))
3408 yywarn("chmod: mode argument is missing initial 0");
3410 LOP(OP_CHMOD,XTERM);
3413 LOP(OP_CHOWN,XTERM);
3416 LOP(OP_CONNECT,XTERM);
3432 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3436 PL_hints |= HINT_BLOCK_SCOPE;
3446 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3447 LOP(OP_DBMOPEN,XTERM);
3453 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3460 yylval.ival = PL_curcop->cop_line;
3474 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3475 UNIBRACK(OP_ENTEREVAL);
3490 case KEY_endhostent:
3496 case KEY_endservent:
3499 case KEY_endprotoent:
3510 yylval.ival = PL_curcop->cop_line;
3512 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3514 if ((PL_bufend - p) >= 3 &&
3515 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3518 if (isIDFIRST_lazy(p))
3519 croak("Missing $ on loop variable");
3524 LOP(OP_FORMLINE,XTERM);
3530 LOP(OP_FCNTL,XTERM);
3536 LOP(OP_FLOCK,XTERM);
3545 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3548 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3563 case KEY_getpriority:
3564 LOP(OP_GETPRIORITY,XTERM);
3566 case KEY_getprotobyname:
3569 case KEY_getprotobynumber:
3570 LOP(OP_GPBYNUMBER,XTERM);
3572 case KEY_getprotoent:
3584 case KEY_getpeername:
3585 UNI(OP_GETPEERNAME);
3587 case KEY_gethostbyname:
3590 case KEY_gethostbyaddr:
3591 LOP(OP_GHBYADDR,XTERM);
3593 case KEY_gethostent:
3596 case KEY_getnetbyname:
3599 case KEY_getnetbyaddr:
3600 LOP(OP_GNBYADDR,XTERM);
3605 case KEY_getservbyname:
3606 LOP(OP_GSBYNAME,XTERM);
3608 case KEY_getservbyport:
3609 LOP(OP_GSBYPORT,XTERM);
3611 case KEY_getservent:
3614 case KEY_getsockname:
3615 UNI(OP_GETSOCKNAME);
3617 case KEY_getsockopt:
3618 LOP(OP_GSOCKOPT,XTERM);
3640 yylval.ival = PL_curcop->cop_line;
3644 LOP(OP_INDEX,XTERM);
3650 LOP(OP_IOCTL,XTERM);
3662 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3693 LOP(OP_LISTEN,XTERM);
3702 s = scan_pat(s,OP_MATCH);
3703 TERM(sublex_start());
3706 LOP(OP_MAPSTART, XREF);
3709 LOP(OP_MKDIR,XTERM);
3712 LOP(OP_MSGCTL,XTERM);
3715 LOP(OP_MSGGET,XTERM);
3718 LOP(OP_MSGRCV,XTERM);
3721 LOP(OP_MSGSND,XTERM);
3726 if (isIDFIRST_lazy(s)) {
3727 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3728 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3729 if (!PL_in_my_stash) {
3732 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3739 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3746 if (PL_expect != XSTATE)
3747 yyerror("\"no\" not allowed in expression");
3748 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3749 s = force_version(s);
3758 if (isIDFIRST_lazy(s)) {
3760 for (d = s; isALNUM_lazy(d); d++) ;
3762 if (strchr("|&*+-=!?:.", *t))
3763 warn("Precedence problem: open %.*s should be open(%.*s)",
3769 yylval.ival = OP_OR;
3779 LOP(OP_OPEN_DIR,XTERM);
3782 checkcomma(s,PL_tokenbuf,"filehandle");
3786 checkcomma(s,PL_tokenbuf,"filehandle");
3805 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3809 LOP(OP_PIPE_OP,XTERM);
3814 missingterm((char*)0);
3815 yylval.ival = OP_CONST;
3816 TERM(sublex_start());
3824 missingterm((char*)0);
3825 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3826 d = SvPV_force(PL_lex_stuff, len);
3827 for (; len; --len, ++d) {
3830 "Possible attempt to separate words with commas");
3835 "Possible attempt to put comments in qw() list");
3841 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3842 PL_lex_stuff = Nullsv;
3845 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3848 yylval.ival = OP_SPLIT;
3852 PL_last_lop = PL_oldbufptr;
3853 PL_last_lop_op = OP_SPLIT;
3859 missingterm((char*)0);
3860 yylval.ival = OP_STRINGIFY;
3861 if (SvIVX(PL_lex_stuff) == '\'')
3862 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3863 TERM(sublex_start());
3866 s = scan_pat(s,OP_QR);
3867 TERM(sublex_start());
3872 missingterm((char*)0);
3873 yylval.ival = OP_BACKTICK;
3875 TERM(sublex_start());
3881 *PL_tokenbuf = '\0';
3882 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3883 if (isIDFIRST_lazy(PL_tokenbuf))
3884 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3886 yyerror("<> should be quotes");
3893 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3897 LOP(OP_RENAME,XTERM);
3906 LOP(OP_RINDEX,XTERM);
3929 LOP(OP_REVERSE,XTERM);
3940 TERM(sublex_start());
3942 TOKEN(1); /* force error */
3951 LOP(OP_SELECT,XTERM);
3957 LOP(OP_SEMCTL,XTERM);
3960 LOP(OP_SEMGET,XTERM);
3963 LOP(OP_SEMOP,XTERM);
3969 LOP(OP_SETPGRP,XTERM);
3971 case KEY_setpriority:
3972 LOP(OP_SETPRIORITY,XTERM);
3974 case KEY_sethostent:
3980 case KEY_setservent:
3983 case KEY_setprotoent:
3993 LOP(OP_SEEKDIR,XTERM);
3995 case KEY_setsockopt:
3996 LOP(OP_SSOCKOPT,XTERM);
4002 LOP(OP_SHMCTL,XTERM);
4005 LOP(OP_SHMGET,XTERM);
4008 LOP(OP_SHMREAD,XTERM);
4011 LOP(OP_SHMWRITE,XTERM);
4014 LOP(OP_SHUTDOWN,XTERM);
4023 LOP(OP_SOCKET,XTERM);
4025 case KEY_socketpair:
4026 LOP(OP_SOCKPAIR,XTERM);
4029 checkcomma(s,PL_tokenbuf,"subroutine name");
4031 if (*s == ';' || *s == ')') /* probably a close */
4032 croak("sort is now a reserved word");
4034 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4038 LOP(OP_SPLIT,XTERM);
4041 LOP(OP_SPRINTF,XTERM);
4044 LOP(OP_SPLICE,XTERM);
4060 LOP(OP_SUBSTR,XTERM);
4067 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4068 char tmpbuf[sizeof PL_tokenbuf];
4070 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4071 if (strchr(tmpbuf, ':'))
4072 sv_setpv(PL_subname, tmpbuf);
4074 sv_setsv(PL_subname,PL_curstname);
4075 sv_catpvn(PL_subname,"::",2);
4076 sv_catpvn(PL_subname,tmpbuf,len);
4078 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4082 PL_expect = XTERMBLOCK;
4083 sv_setpv(PL_subname,"?");
4086 if (tmp == KEY_format) {
4089 PL_lex_formbrack = PL_lex_brackets + 1;
4093 /* Look for a prototype */
4100 SvREFCNT_dec(PL_lex_stuff);
4101 PL_lex_stuff = Nullsv;
4102 croak("Prototype not terminated");
4105 d = SvPVX(PL_lex_stuff);
4107 for (p = d; *p; ++p) {
4112 SvCUR(PL_lex_stuff) = tmp;
4115 PL_nextval[1] = PL_nextval[0];
4116 PL_nexttype[1] = PL_nexttype[0];
4117 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4118 PL_nexttype[0] = THING;
4119 if (PL_nexttoke == 1) {
4120 PL_lex_defer = PL_lex_state;
4121 PL_lex_expect = PL_expect;
4122 PL_lex_state = LEX_KNOWNEXT;
4124 PL_lex_stuff = Nullsv;
4127 if (*SvPV(PL_subname,n_a) == '?') {
4128 sv_setpv(PL_subname,"__ANON__");
4135 LOP(OP_SYSTEM,XREF);
4138 LOP(OP_SYMLINK,XTERM);
4141 LOP(OP_SYSCALL,XTERM);
4144 LOP(OP_SYSOPEN,XTERM);
4147 LOP(OP_SYSSEEK,XTERM);
4150 LOP(OP_SYSREAD,XTERM);
4153 LOP(OP_SYSWRITE,XTERM);
4157 TERM(sublex_start());
4178 LOP(OP_TRUNCATE,XTERM);
4190 yylval.ival = PL_curcop->cop_line;
4194 yylval.ival = PL_curcop->cop_line;
4198 LOP(OP_UNLINK,XTERM);
4204 LOP(OP_UNPACK,XTERM);
4207 LOP(OP_UTIME,XTERM);
4210 if (ckWARN(WARN_OCTAL)) {
4211 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4212 if (*d != '0' && isDIGIT(*d))
4213 yywarn("umask: argument is missing initial 0");
4218 LOP(OP_UNSHIFT,XTERM);
4221 if (PL_expect != XSTATE)
4222 yyerror("\"use\" not allowed in expression");
4225 s = force_version(s);
4226 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4227 PL_nextval[PL_nexttoke].opval = Nullop;
4232 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4233 s = force_version(s);
4246 yylval.ival = PL_curcop->cop_line;
4250 PL_hints |= HINT_BLOCK_SCOPE;
4257 LOP(OP_WAITPID,XTERM);
4265 static char ctl_l[2];
4267 if (ctl_l[0] == '\0')
4268 ctl_l[0] = toCTRL('L');
4269 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4272 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4277 if (PL_expect == XOPERATOR)
4283 yylval.ival = OP_XOR;
4288 TERM(sublex_start());
4294 keyword(register char *d, I32 len)
4299 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4300 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4301 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4302 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4303 if (strEQ(d,"__END__")) return KEY___END__;
4307 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4312 if (strEQ(d,"and")) return -KEY_and;
4313 if (strEQ(d,"abs")) return -KEY_abs;
4316 if (strEQ(d,"alarm")) return -KEY_alarm;
4317 if (strEQ(d,"atan2")) return -KEY_atan2;
4320 if (strEQ(d,"accept")) return -KEY_accept;
4325 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4328 if (strEQ(d,"bless")) return -KEY_bless;
4329 if (strEQ(d,"bind")) return -KEY_bind;
4330 if (strEQ(d,"binmode")) return -KEY_binmode;
4333 if (strEQ(d,"CORE")) return -KEY_CORE;
4338 if (strEQ(d,"cmp")) return -KEY_cmp;
4339 if (strEQ(d,"chr")) return -KEY_chr;
4340 if (strEQ(d,"cos")) return -KEY_cos;
4343 if (strEQ(d,"chop")) return KEY_chop;
4346 if (strEQ(d,"close")) return -KEY_close;
4347 if (strEQ(d,"chdir")) return -KEY_chdir;
4348 if (strEQ(d,"chomp")) return KEY_chomp;
4349 if (strEQ(d,"chmod")) return -KEY_chmod;
4350 if (strEQ(d,"chown")) return -KEY_chown;
4351 if (strEQ(d,"crypt")) return -KEY_crypt;
4354 if (strEQ(d,"chroot")) return -KEY_chroot;
4355 if (strEQ(d,"caller")) return -KEY_caller;
4358 if (strEQ(d,"connect")) return -KEY_connect;
4361 if (strEQ(d,"closedir")) return -KEY_closedir;
4362 if (strEQ(d,"continue")) return -KEY_continue;
4367 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4372 if (strEQ(d,"do")) return KEY_do;
4375 if (strEQ(d,"die")) return -KEY_die;
4378 if (strEQ(d,"dump")) return -KEY_dump;
4381 if (strEQ(d,"delete")) return KEY_delete;
4384 if (strEQ(d,"defined")) return KEY_defined;
4385 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4388 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4393 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4394 if (strEQ(d,"END")) return KEY_END;
4399 if (strEQ(d,"eq")) return -KEY_eq;
4402 if (strEQ(d,"eof")) return -KEY_eof;
4403 if (strEQ(d,"exp")) return -KEY_exp;
4406 if (strEQ(d,"else")) return KEY_else;
4407 if (strEQ(d,"exit")) return -KEY_exit;
4408 if (strEQ(d,"eval")) return KEY_eval;
4409 if (strEQ(d,"exec")) return -KEY_exec;
4410 if (strEQ(d,"each")) return KEY_each;
4413 if (strEQ(d,"elsif")) return KEY_elsif;
4416 if (strEQ(d,"exists")) return KEY_exists;
4417 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4420 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4421 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4424 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4427 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4428 if (strEQ(d,"endservent")) return -KEY_endservent;
4431 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4438 if (strEQ(d,"for")) return KEY_for;
4441 if (strEQ(d,"fork")) return -KEY_fork;
4444 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4445 if (strEQ(d,"flock")) return -KEY_flock;
4448 if (strEQ(d,"format")) return KEY_format;
4449 if (strEQ(d,"fileno")) return -KEY_fileno;
4452 if (strEQ(d,"foreach")) return KEY_foreach;
4455 if (strEQ(d,"formline")) return -KEY_formline;
4461 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4462 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4466 if (strnEQ(d,"get",3)) {
4471 if (strEQ(d,"ppid")) return -KEY_getppid;
4472 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4475 if (strEQ(d,"pwent")) return -KEY_getpwent;
4476 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4477 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4480 if (strEQ(d,"peername")) return -KEY_getpeername;
4481 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4482 if (strEQ(d,"priority")) return -KEY_getpriority;
4485 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4488 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4492 else if (*d == 'h') {
4493 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4494 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4495 if (strEQ(d,"hostent")) return -KEY_gethostent;
4497 else if (*d == 'n') {
4498 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4499 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4500 if (strEQ(d,"netent")) return -KEY_getnetent;
4502 else if (*d == 's') {
4503 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4504 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4505 if (strEQ(d,"servent")) return -KEY_getservent;
4506 if (strEQ(d,"sockname")) return -KEY_getsockname;
4507 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4509 else if (*d == 'g') {
4510 if (strEQ(d,"grent")) return -KEY_getgrent;
4511 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4512 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4514 else if (*d == 'l') {
4515 if (strEQ(d,"login")) return -KEY_getlogin;
4517 else if (strEQ(d,"c")) return -KEY_getc;
4522 if (strEQ(d,"gt")) return -KEY_gt;
4523 if (strEQ(d,"ge")) return -KEY_ge;
4526 if (strEQ(d,"grep")) return KEY_grep;
4527 if (strEQ(d,"goto")) return KEY_goto;
4528 if (strEQ(d,"glob")) return KEY_glob;
4531 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4536 if (strEQ(d,"hex")) return -KEY_hex;
4539 if (strEQ(d,"INIT")) return KEY_INIT;
4544 if (strEQ(d,"if")) return KEY_if;
4547 if (strEQ(d,"int")) return -KEY_int;
4550 if (strEQ(d,"index")) return -KEY_index;
4551 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4556 if (strEQ(d,"join")) return -KEY_join;
4560 if (strEQ(d,"keys")) return KEY_keys;
4561 if (strEQ(d,"kill")) return -KEY_kill;
4566 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4567 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4573 if (strEQ(d,"lt")) return -KEY_lt;
4574 if (strEQ(d,"le")) return -KEY_le;
4575 if (strEQ(d,"lc")) return -KEY_lc;
4578 if (strEQ(d,"log")) return -KEY_log;
4581 if (strEQ(d,"last")) return KEY_last;
4582 if (strEQ(d,"link")) return -KEY_link;
4583 if (strEQ(d,"lock")) return -KEY_lock;
4586 if (strEQ(d,"local")) return KEY_local;
4587 if (strEQ(d,"lstat")) return -KEY_lstat;
4590 if (strEQ(d,"length")) return -KEY_length;
4591 if (strEQ(d,"listen")) return -KEY_listen;
4594 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4597 if (strEQ(d,"localtime")) return -KEY_localtime;
4603 case 1: return KEY_m;
4605 if (strEQ(d,"my")) return KEY_my;
4608 if (strEQ(d,"map")) return KEY_map;
4611 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4614 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4615 if (strEQ(d,"msgget")) return -KEY_msgget;
4616 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4617 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4622 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4625 if (strEQ(d,"next")) return KEY_next;
4626 if (strEQ(d,"ne")) return -KEY_ne;
4627 if (strEQ(d,"not")) return -KEY_not;
4628 if (strEQ(d,"no")) return KEY_no;
4633 if (strEQ(d,"or")) return -KEY_or;
4636 if (strEQ(d,"ord")) return -KEY_ord;
4637 if (strEQ(d,"oct")) return -KEY_oct;
4638 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4642 if (strEQ(d,"open")) return -KEY_open;
4645 if (strEQ(d,"opendir")) return -KEY_opendir;
4652 if (strEQ(d,"pop")) return KEY_pop;
4653 if (strEQ(d,"pos")) return KEY_pos;
4656 if (strEQ(d,"push")) return KEY_push;
4657 if (strEQ(d,"pack")) return -KEY_pack;
4658 if (strEQ(d,"pipe")) return -KEY_pipe;
4661 if (strEQ(d,"print")) return KEY_print;
4664 if (strEQ(d,"printf")) return KEY_printf;
4667 if (strEQ(d,"package")) return KEY_package;
4670 if (strEQ(d,"prototype")) return KEY_prototype;
4675 if (strEQ(d,"q")) return KEY_q;
4676 if (strEQ(d,"qr")) return KEY_qr;
4677 if (strEQ(d,"qq")) return KEY_qq;
4678 if (strEQ(d,"qw")) return KEY_qw;
4679 if (strEQ(d,"qx")) return KEY_qx;
4681 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4686 if (strEQ(d,"ref")) return -KEY_ref;
4689 if (strEQ(d,"read")) return -KEY_read;
4690 if (strEQ(d,"rand")) return -KEY_rand;
4691 if (strEQ(d,"recv")) return -KEY_recv;
4692 if (strEQ(d,"redo")) return KEY_redo;
4695 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4696 if (strEQ(d,"reset")) return -KEY_reset;
4699 if (strEQ(d,"return")) return KEY_return;
4700 if (strEQ(d,"rename")) return -KEY_rename;
4701 if (strEQ(d,"rindex")) return -KEY_rindex;
4704 if (strEQ(d,"require")) return -KEY_require;
4705 if (strEQ(d,"reverse")) return -KEY_reverse;
4706 if (strEQ(d,"readdir")) return -KEY_readdir;
4709 if (strEQ(d,"readlink")) return -KEY_readlink;
4710 if (strEQ(d,"readline")) return -KEY_readline;
4711 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4714 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4720 case 0: return KEY_s;
4722 if (strEQ(d,"scalar")) return KEY_scalar;
4727 if (strEQ(d,"seek")) return -KEY_seek;
4728 if (strEQ(d,"send")) return -KEY_send;
4731 if (strEQ(d,"semop")) return -KEY_semop;
4734 if (strEQ(d,"select")) return -KEY_select;
4735 if (strEQ(d,"semctl")) return -KEY_semctl;
4736 if (strEQ(d,"semget")) return -KEY_semget;
4739 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4740 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4743 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4744 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4747 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4750 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4751 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4752 if (strEQ(d,"setservent")) return -KEY_setservent;
4755 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4756 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4763 if (strEQ(d,"shift")) return KEY_shift;
4766 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4767 if (strEQ(d,"shmget")) return -KEY_shmget;
4770 if (strEQ(d,"shmread")) return -KEY_shmread;
4773 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4774 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4779 if (strEQ(d,"sin")) return -KEY_sin;
4782 if (strEQ(d,"sleep")) return -KEY_sleep;
4785 if (strEQ(d,"sort")) return KEY_sort;
4786 if (strEQ(d,"socket")) return -KEY_socket;
4787 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4790 if (strEQ(d,"split")) return KEY_split;
4791 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4792 if (strEQ(d,"splice")) return KEY_splice;
4795 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4798 if (strEQ(d,"srand")) return -KEY_srand;
4801 if (strEQ(d,"stat")) return -KEY_stat;
4802 if (strEQ(d,"study")) return KEY_study;
4805 if (strEQ(d,"substr")) return -KEY_substr;
4806 if (strEQ(d,"sub")) return KEY_sub;
4811 if (strEQ(d,"system")) return -KEY_system;
4814 if (strEQ(d,"symlink")) return -KEY_symlink;
4815 if (strEQ(d,"syscall")) return -KEY_syscall;
4816 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4817 if (strEQ(d,"sysread")) return -KEY_sysread;
4818 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4821 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4830 if (strEQ(d,"tr")) return KEY_tr;
4833 if (strEQ(d,"tie")) return KEY_tie;
4836 if (strEQ(d,"tell")) return -KEY_tell;
4837 if (strEQ(d,"tied")) return KEY_tied;
4838 if (strEQ(d,"time")) return -KEY_time;
4841 if (strEQ(d,"times")) return -KEY_times;
4844 if (strEQ(d,"telldir")) return -KEY_telldir;
4847 if (strEQ(d,"truncate")) return -KEY_truncate;
4854 if (strEQ(d,"uc")) return -KEY_uc;
4857 if (strEQ(d,"use")) return KEY_use;
4860 if (strEQ(d,"undef")) return KEY_undef;
4861 if (strEQ(d,"until")) return KEY_until;
4862 if (strEQ(d,"untie")) return KEY_untie;
4863 if (strEQ(d,"utime")) return -KEY_utime;
4864 if (strEQ(d,"umask")) return -KEY_umask;
4867 if (strEQ(d,"unless")) return KEY_unless;
4868 if (strEQ(d,"unpack")) return -KEY_unpack;
4869 if (strEQ(d,"unlink")) return -KEY_unlink;
4872 if (strEQ(d,"unshift")) return KEY_unshift;
4873 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4878 if (strEQ(d,"values")) return -KEY_values;
4879 if (strEQ(d,"vec")) return -KEY_vec;
4884 if (strEQ(d,"warn")) return -KEY_warn;
4885 if (strEQ(d,"wait")) return -KEY_wait;
4888 if (strEQ(d,"while")) return KEY_while;
4889 if (strEQ(d,"write")) return -KEY_write;
4892 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4895 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4900 if (len == 1) return -KEY_x;
4901 if (strEQ(d,"xor")) return -KEY_xor;
4904 if (len == 1) return KEY_y;
4913 checkcomma(register char *s, char *name, char *what)
4917 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4918 dTHR; /* only for ckWARN */
4919 if (ckWARN(WARN_SYNTAX)) {
4921 for (w = s+2; *w && level; w++) {
4928 for (; *w && isSPACE(*w); w++) ;
4929 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4930 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4933 while (s < PL_bufend && isSPACE(*s))
4937 while (s < PL_bufend && isSPACE(*s))
4939 if (isIDFIRST_lazy(s)) {
4941 while (isALNUM_lazy(s))
4943 while (s < PL_bufend && isSPACE(*s))
4948 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4952 croak("No comma allowed after %s", what);
4958 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4961 HV *table = GvHV(PL_hintgv); /* ^H */
4964 bool oldcatch = CATCH_GET;
4969 yyerror("%^H is not defined");
4972 cvp = hv_fetch(table, key, strlen(key), FALSE);
4973 if (!cvp || !SvOK(*cvp)) {
4975 sprintf(buf,"$^H{%s} is not defined", key);
4979 sv_2mortal(sv); /* Parent created it permanently */
4982 pv = sv_2mortal(newSVpv(s, len));
4984 typesv = sv_2mortal(newSVpv(type, 0));
4986 typesv = &PL_sv_undef;
4988 Zero(&myop, 1, BINOP);
4989 myop.op_last = (OP *) &myop;
4990 myop.op_next = Nullop;
4991 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4993 PUSHSTACKi(PERLSI_OVERLOAD);
4996 PL_op = (OP *) &myop;
4997 if (PERLDB_SUB && PL_curstash != PL_debstash)
4998 PL_op->op_private |= OPpENTERSUB_DB;
5009 if (PL_op = pp_entersub(ARGS))
5016 CATCH_SET(oldcatch);
5021 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5024 return SvREFCNT_inc(res);
5028 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5030 register char *d = dest;
5031 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5034 croak(ident_too_long);
5035 if (isALNUM(*s)) /* UTF handled below */
5037 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5042 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5046 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5047 char *t = s + UTF8SKIP(s);
5048 while (*t & 0x80 && is_utf8_mark((U8*)t))
5050 if (d + (t - s) > e)
5051 croak(ident_too_long);
5052 Copy(s, d, t - s, char);
5065 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5072 if (PL_lex_brackets == 0)
5073 PL_lex_fakebrack = 0;
5077 e = d + destlen - 3; /* two-character token, ending NUL */
5079 while (isDIGIT(*s)) {
5081 croak(ident_too_long);
5088 croak(ident_too_long);
5089 if (isALNUM(*s)) /* UTF handled below */
5091 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5096 else if (*s == ':' && s[1] == ':') {
5100 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5101 char *t = s + UTF8SKIP(s);
5102 while (*t & 0x80 && is_utf8_mark((U8*)t))
5104 if (d + (t - s) > e)
5105 croak(ident_too_long);
5106 Copy(s, d, t - s, char);
5117 if (PL_lex_state != LEX_NORMAL)
5118 PL_lex_state = LEX_INTERPENDMAYBE;
5121 if (*s == '$' && s[1] &&
5122 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5135 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5140 if (isSPACE(s[-1])) {
5143 if (ch != ' ' && ch != '\t') {
5149 if (isIDFIRST_lazy(d)) {
5153 while (e < send && isALNUM_lazy(e) || *e == ':') {
5155 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5158 Copy(s, d, e - s, char);
5163 while (isALNUM(*s) || *s == ':')
5167 while (s < send && (*s == ' ' || *s == '\t')) s++;
5168 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5169 dTHR; /* only for ckWARN */
5170 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5171 char *brack = *s == '[' ? "[...]" : "{...}";
5172 warner(WARN_AMBIGUOUS,
5173 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5174 funny, dest, brack, funny, dest, brack);
5176 PL_lex_fakebrack = PL_lex_brackets+1;
5178 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5184 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5185 PL_lex_state = LEX_INTERPEND;
5188 if (PL_lex_state == LEX_NORMAL) {
5189 dTHR; /* only for ckWARN */
5190 if (ckWARN(WARN_AMBIGUOUS) &&
5191 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5193 warner(WARN_AMBIGUOUS,
5194 "Ambiguous use of %c{%s} resolved to %c%s",
5195 funny, dest, funny, dest);
5200 s = bracket; /* let the parser handle it */
5204 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5205 PL_lex_state = LEX_INTERPEND;
5209 void pmflag(U16 *pmfl, int ch)
5214 *pmfl |= PMf_GLOBAL;
5216 *pmfl |= PMf_CONTINUE;
5220 *pmfl |= PMf_MULTILINE;
5222 *pmfl |= PMf_SINGLELINE;
5224 *pmfl |= PMf_EXTENDED;
5228 scan_pat(char *start, I32 type)
5233 s = scan_str(start);
5236 SvREFCNT_dec(PL_lex_stuff);
5237 PL_lex_stuff = Nullsv;
5238 croak("Search pattern not terminated");
5241 pm = (PMOP*)newPMOP(type, 0);
5242 if (PL_multi_open == '?')
5243 pm->op_pmflags |= PMf_ONCE;
5245 while (*s && strchr("iomsx", *s))
5246 pmflag(&pm->op_pmflags,*s++);
5249 while (*s && strchr("iogcmsx", *s))
5250 pmflag(&pm->op_pmflags,*s++);
5252 pm->op_pmpermflags = pm->op_pmflags;
5254 PL_lex_op = (OP*)pm;
5255 yylval.ival = OP_MATCH;
5260 scan_subst(char *start)
5267 yylval.ival = OP_NULL;
5269 s = scan_str(start);
5273 SvREFCNT_dec(PL_lex_stuff);
5274 PL_lex_stuff = Nullsv;
5275 croak("Substitution pattern not terminated");
5278 if (s[-1] == PL_multi_open)
5281 first_start = PL_multi_start;
5285 SvREFCNT_dec(PL_lex_stuff);
5286 PL_lex_stuff = Nullsv;
5288 SvREFCNT_dec(PL_lex_repl);
5289 PL_lex_repl = Nullsv;
5290 croak("Substitution replacement not terminated");
5292 PL_multi_start = first_start; /* so whole substitution is taken together */
5294 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5300 else if (strchr("iogcmsx", *s))
5301 pmflag(&pm->op_pmflags,*s++);
5308 pm->op_pmflags |= PMf_EVAL;
5309 repl = newSVpv("",0);
5311 sv_catpv(repl, es ? "eval " : "do ");
5312 sv_catpvn(repl, "{ ", 2);
5313 sv_catsv(repl, PL_lex_repl);
5314 sv_catpvn(repl, " };", 2);
5315 SvCOMPILED_on(repl);
5316 SvREFCNT_dec(PL_lex_repl);
5320 pm->op_pmpermflags = pm->op_pmflags;
5321 PL_lex_op = (OP*)pm;
5322 yylval.ival = OP_SUBST;
5327 scan_trans(char *start)
5338 yylval.ival = OP_NULL;
5340 s = scan_str(start);
5343 SvREFCNT_dec(PL_lex_stuff);
5344 PL_lex_stuff = Nullsv;
5345 croak("Transliteration pattern not terminated");
5347 if (s[-1] == PL_multi_open)
5353 SvREFCNT_dec(PL_lex_stuff);
5354 PL_lex_stuff = Nullsv;
5356 SvREFCNT_dec(PL_lex_repl);
5357 PL_lex_repl = Nullsv;
5358 croak("Transliteration replacement not terminated");
5362 o = newSVOP(OP_TRANS, 0, 0);
5363 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5366 New(803,tbl,256,short);
5367 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5371 complement = del = squash = 0;
5372 while (strchr("cdsCU", *s)) {
5374 complement = OPpTRANS_COMPLEMENT;
5376 del = OPpTRANS_DELETE;
5378 squash = OPpTRANS_SQUASH;
5383 utf8 &= ~OPpTRANS_FROM_UTF;
5385 utf8 |= OPpTRANS_FROM_UTF;
5389 utf8 &= ~OPpTRANS_TO_UTF;
5391 utf8 |= OPpTRANS_TO_UTF;
5394 croak("Too many /C and /U options");
5399 o->op_private = del|squash|complement|utf8;
5402 yylval.ival = OP_TRANS;
5407 scan_heredoc(register char *s)
5411 I32 op_type = OP_SCALAR;
5418 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5422 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5425 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5426 if (*peek && strchr("`'\"",*peek)) {
5429 s = delimcpy(d, e, s, PL_bufend, term, &len);
5439 if (!isALNUM_lazy(s))
5440 deprecate("bare << to mean <<\"\"");
5441 for (; isALNUM_lazy(s); s++) {
5446 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5447 croak("Delimiter for here document is too long");
5450 len = d - PL_tokenbuf;
5451 #ifndef PERL_STRICT_CR
5452 d = strchr(s, '\r');
5456 while (s < PL_bufend) {
5462 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5471 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5476 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5477 herewas = newSVpv(s,PL_bufend-s);
5479 s--, herewas = newSVpv(s,d-s);
5480 s += SvCUR(herewas);
5482 tmpstr = NEWSV(87,79);
5483 sv_upgrade(tmpstr, SVt_PVIV);
5488 else if (term == '`') {
5489 op_type = OP_BACKTICK;
5490 SvIVX(tmpstr) = '\\';
5494 PL_multi_start = PL_curcop->cop_line;
5495 PL_multi_open = PL_multi_close = '<';
5496 term = *PL_tokenbuf;
5499 while (s < PL_bufend &&
5500 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5502 PL_curcop->cop_line++;
5504 if (s >= PL_bufend) {
5505 PL_curcop->cop_line = PL_multi_start;
5506 missingterm(PL_tokenbuf);
5508 sv_setpvn(tmpstr,d+1,s-d);
5510 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5512 sv_catpvn(herewas,s,PL_bufend-s);
5513 sv_setsv(PL_linestr,herewas);
5514 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5515 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5518 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5519 while (s >= PL_bufend) { /* multiple line string? */
5521 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5522 PL_curcop->cop_line = PL_multi_start;
5523 missingterm(PL_tokenbuf);
5525 PL_curcop->cop_line++;
5526 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5527 #ifndef PERL_STRICT_CR
5528 if (PL_bufend - PL_linestart >= 2) {
5529 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5530 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5532 PL_bufend[-2] = '\n';
5534 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5536 else if (PL_bufend[-1] == '\r')
5537 PL_bufend[-1] = '\n';
5539 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5540 PL_bufend[-1] = '\n';
5542 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5543 SV *sv = NEWSV(88,0);
5545 sv_upgrade(sv, SVt_PVMG);
5546 sv_setsv(sv,PL_linestr);
5547 av_store(GvAV(PL_curcop->cop_filegv),
5548 (I32)PL_curcop->cop_line,sv);
5550 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5553 sv_catsv(PL_linestr,herewas);
5554 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5558 sv_catsv(tmpstr,PL_linestr);
5561 PL_multi_end = PL_curcop->cop_line;
5563 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5564 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5565 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5567 SvREFCNT_dec(herewas);
5568 PL_lex_stuff = tmpstr;
5569 yylval.ival = op_type;
5574 takes: current position in input buffer
5575 returns: new position in input buffer
5576 side-effects: yylval and lex_op are set.
5581 <FH> read from filehandle
5582 <pkg::FH> read from package qualified filehandle
5583 <pkg'FH> read from package qualified filehandle
5584 <$fh> read from filehandle in $fh
5590 scan_inputsymbol(char *start)
5592 register char *s = start; /* current position in buffer */
5597 d = PL_tokenbuf; /* start of temp holding space */
5598 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5599 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5601 /* die if we didn't have space for the contents of the <>,
5605 if (len >= sizeof PL_tokenbuf)
5606 croak("Excessively long <> operator");
5608 croak("Unterminated <> operator");
5613 Remember, only scalar variables are interpreted as filehandles by
5614 this code. Anything more complex (e.g., <$fh{$num}>) will be
5615 treated as a glob() call.
5616 This code makes use of the fact that except for the $ at the front,
5617 a scalar variable and a filehandle look the same.
5619 if (*d == '$' && d[1]) d++;
5621 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5622 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5625 /* If we've tried to read what we allow filehandles to look like, and
5626 there's still text left, then it must be a glob() and not a getline.
5627 Use scan_str to pull out the stuff between the <> and treat it
5628 as nothing more than a string.
5631 if (d - PL_tokenbuf != len) {
5632 yylval.ival = OP_GLOB;
5634 s = scan_str(start);
5636 croak("Glob not terminated");
5640 /* we're in a filehandle read situation */
5643 /* turn <> into <ARGV> */
5645 (void)strcpy(d,"ARGV");
5647 /* if <$fh>, create the ops to turn the variable into a
5653 /* try to find it in the pad for this block, otherwise find
5654 add symbol table ops
5656 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5657 OP *o = newOP(OP_PADSV, 0);
5659 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5662 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5663 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5664 newUNOP(OP_RV2SV, 0,
5665 newGVOP(OP_GV, 0, gv)));
5667 PL_lex_op->op_flags |= OPf_SPECIAL;
5668 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5669 yylval.ival = OP_NULL;
5672 /* If it's none of the above, it must be a literal filehandle
5673 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5675 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5676 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5677 yylval.ival = OP_NULL;
5686 takes: start position in buffer
5687 returns: position to continue reading from buffer
5688 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5689 updates the read buffer.
5691 This subroutine pulls a string out of the input. It is called for:
5692 q single quotes q(literal text)
5693 ' single quotes 'literal text'
5694 qq double quotes qq(interpolate $here please)
5695 " double quotes "interpolate $here please"
5696 qx backticks qx(/bin/ls -l)
5697 ` backticks `/bin/ls -l`
5698 qw quote words @EXPORT_OK = qw( func() $spam )
5699 m// regexp match m/this/
5700 s/// regexp substitute s/this/that/
5701 tr/// string transliterate tr/this/that/
5702 y/// string transliterate y/this/that/
5703 ($*@) sub prototypes sub foo ($)
5704 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5706 In most of these cases (all but <>, patterns and transliterate)
5707 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5708 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5709 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5712 It skips whitespace before the string starts, and treats the first
5713 character as the delimiter. If the delimiter is one of ([{< then
5714 the corresponding "close" character )]}> is used as the closing
5715 delimiter. It allows quoting of delimiters, and if the string has
5716 balanced delimiters ([{<>}]) it allows nesting.
5718 The lexer always reads these strings into lex_stuff, except in the
5719 case of the operators which take *two* arguments (s/// and tr///)
5720 when it checks to see if lex_stuff is full (presumably with the 1st
5721 arg to s or tr) and if so puts the string into lex_repl.
5726 scan_str(char *start)
5729 SV *sv; /* scalar value: string */
5730 char *tmps; /* temp string, used for delimiter matching */
5731 register char *s = start; /* current position in the buffer */
5732 register char term; /* terminating character */
5733 register char *to; /* current position in the sv's data */
5734 I32 brackets = 1; /* bracket nesting level */
5736 /* skip space before the delimiter */
5740 /* mark where we are, in case we need to report errors */
5743 /* after skipping whitespace, the next character is the terminator */
5745 /* mark where we are */
5746 PL_multi_start = PL_curcop->cop_line;
5747 PL_multi_open = term;
5749 /* find corresponding closing delimiter */
5750 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5752 PL_multi_close = term;
5754 /* create a new SV to hold the contents. 87 is leak category, I'm
5755 assuming. 79 is the SV's initial length. What a random number. */
5757 sv_upgrade(sv, SVt_PVIV);
5759 (void)SvPOK_only(sv); /* validate pointer */
5761 /* move past delimiter and try to read a complete string */
5764 /* extend sv if need be */
5765 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5766 /* set 'to' to the next character in the sv's string */
5767 to = SvPVX(sv)+SvCUR(sv);
5769 /* if open delimiter is the close delimiter read unbridle */
5770 if (PL_multi_open == PL_multi_close) {
5771 for (; s < PL_bufend; s++,to++) {
5772 /* embedded newlines increment the current line number */
5773 if (*s == '\n' && !PL_rsfp)
5774 PL_curcop->cop_line++;
5775 /* handle quoted delimiters */
5776 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5779 /* any other quotes are simply copied straight through */
5783 /* terminate when run out of buffer (the for() condition), or
5784 have found the terminator */
5785 else if (*s == term)
5791 /* if the terminator isn't the same as the start character (e.g.,
5792 matched brackets), we have to allow more in the quoting, and
5793 be prepared for nested brackets.
5796 /* read until we run out of string, or we find the terminator */
5797 for (; s < PL_bufend; s++,to++) {
5798 /* embedded newlines increment the line count */
5799 if (*s == '\n' && !PL_rsfp)
5800 PL_curcop->cop_line++;
5801 /* backslashes can escape the open or closing characters */
5802 if (*s == '\\' && s+1 < PL_bufend) {
5803 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5808 /* allow nested opens and closes */
5809 else if (*s == PL_multi_close && --brackets <= 0)
5811 else if (*s == PL_multi_open)
5816 /* terminate the copied string and update the sv's end-of-string */
5818 SvCUR_set(sv, to - SvPVX(sv));
5821 * this next chunk reads more into the buffer if we're not done yet
5824 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5826 #ifndef PERL_STRICT_CR
5827 if (to - SvPVX(sv) >= 2) {
5828 if ((to[-2] == '\r' && to[-1] == '\n') ||
5829 (to[-2] == '\n' && to[-1] == '\r'))
5833 SvCUR_set(sv, to - SvPVX(sv));
5835 else if (to[-1] == '\r')
5838 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5842 /* if we're out of file, or a read fails, bail and reset the current
5843 line marker so we can report where the unterminated string began
5846 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5848 PL_curcop->cop_line = PL_multi_start;
5851 /* we read a line, so increment our line counter */
5852 PL_curcop->cop_line++;
5854 /* update debugger info */
5855 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5856 SV *sv = NEWSV(88,0);
5858 sv_upgrade(sv, SVt_PVMG);
5859 sv_setsv(sv,PL_linestr);
5860 av_store(GvAV(PL_curcop->cop_filegv),
5861 (I32)PL_curcop->cop_line, sv);
5864 /* having changed the buffer, we must update PL_bufend */
5865 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5868 /* at this point, we have successfully read the delimited string */
5870 PL_multi_end = PL_curcop->cop_line;
5873 /* if we allocated too much space, give some back */
5874 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5875 SvLEN_set(sv, SvCUR(sv) + 1);
5876 Renew(SvPVX(sv), SvLEN(sv), char);
5879 /* decide whether this is the first or second quoted string we've read
5892 takes: pointer to position in buffer
5893 returns: pointer to new position in buffer
5894 side-effects: builds ops for the constant in yylval.op
5896 Read a number in any of the formats that Perl accepts:
5898 0(x[0-7A-F]+)|([0-7]+)
5899 [\d_]+(\.[\d_]*)?[Ee](\d+)
5901 Underbars (_) are allowed in decimal numbers. If -w is on,
5902 underbars before a decimal point must be at three digit intervals.
5904 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5907 If it reads a number without a decimal point or an exponent, it will
5908 try converting the number to an integer and see if it can do so
5909 without loss of precision.
5913 scan_num(char *start)
5915 register char *s = start; /* current position in buffer */
5916 register char *d; /* destination in temp buffer */
5917 register char *e; /* end of temp buffer */
5918 I32 tryiv; /* used to see if it can be an int */
5919 double value; /* number read, as a double */
5920 SV *sv; /* place to put the converted number */
5921 I32 floatit; /* boolean: int or float? */
5922 char *lastub = 0; /* position of last underbar */
5923 static char number_too_long[] = "Number too long";
5925 /* We use the first character to decide what type of number this is */
5929 croak("panic: scan_num");
5931 /* if it starts with a 0, it could be an octal number, a decimal in
5932 0.13 disguise, or a hexadecimal number.
5937 u holds the "number so far"
5938 shift the power of 2 of the base (hex == 4, octal == 3)
5939 overflowed was the number more than we can hold?
5941 Shift is used when we add a digit. It also serves as an "are
5942 we in octal or hex?" indicator to disallow hex characters when
5947 bool overflowed = FALSE;
5954 /* check for a decimal in disguise */
5955 else if (s[1] == '.')
5957 /* so it must be octal */
5962 /* read the rest of the octal number */
5964 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5968 /* if we don't mention it, we're done */
5977 /* 8 and 9 are not octal */
5980 yyerror("Illegal octal digit");
5984 case '0': case '1': case '2': case '3': case '4':
5985 case '5': case '6': case '7':
5986 b = *s++ & 15; /* ASCII digit -> value of digit */
5990 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5991 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5992 /* make sure they said 0x */
5997 /* Prepare to put the digit we have onto the end
5998 of the number so far. We check for overflows.
6002 n = u << shift; /* make room for the digit */
6003 if (!overflowed && (n >> shift) != u
6004 && !(PL_hints & HINT_NEW_BINARY)) {
6005 warn("Integer overflow in %s number",
6006 (shift == 4) ? "hex" : "octal");
6009 u = n | b; /* add the digit to the end */
6014 /* if we get here, we had success: make a scalar value from
6020 if ( PL_hints & HINT_NEW_BINARY)
6021 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6026 handle decimal numbers.
6027 we're also sent here when we read a 0 as the first digit
6029 case '1': case '2': case '3': case '4': case '5':
6030 case '6': case '7': case '8': case '9': case '.':
6033 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6036 /* read next group of digits and _ and copy into d */
6037 while (isDIGIT(*s) || *s == '_') {
6038 /* skip underscores, checking for misplaced ones
6042 dTHR; /* only for ckWARN */
6043 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6044 warner(WARN_SYNTAX, "Misplaced _ in number");
6048 /* check for end of fixed-length buffer */
6050 croak(number_too_long);
6051 /* if we're ok, copy the character */
6056 /* final misplaced underbar check */
6057 if (lastub && s - lastub != 3) {
6059 if (ckWARN(WARN_SYNTAX))
6060 warner(WARN_SYNTAX, "Misplaced _ in number");
6063 /* read a decimal portion if there is one. avoid
6064 3..5 being interpreted as the number 3. followed
6067 if (*s == '.' && s[1] != '.') {
6071 /* copy, ignoring underbars, until we run out of
6072 digits. Note: no misplaced underbar checks!
6074 for (; isDIGIT(*s) || *s == '_'; s++) {
6075 /* fixed length buffer check */
6077 croak(number_too_long);
6083 /* read exponent part, if present */
6084 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6088 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6089 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6091 /* allow positive or negative exponent */
6092 if (*s == '+' || *s == '-')
6095 /* read digits of exponent (no underbars :-) */
6096 while (isDIGIT(*s)) {
6098 croak(number_too_long);
6103 /* terminate the string */
6106 /* make an sv from the string */
6108 /* reset numeric locale in case we were earlier left in Swaziland */
6109 SET_NUMERIC_STANDARD();
6110 value = atof(PL_tokenbuf);
6113 See if we can make do with an integer value without loss of
6114 precision. We use I_V to cast to an int, because some
6115 compilers have issues. Then we try casting it back and see
6116 if it was the same. We only do this if we know we
6117 specifically read an integer.
6119 Note: if floatit is true, then we don't need to do the
6123 if (!floatit && (double)tryiv == value)
6124 sv_setiv(sv, tryiv);
6126 sv_setnv(sv, value);
6127 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6128 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6129 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6133 /* make the op for the constant and return */
6135 yylval.opval = newSVOP(OP_CONST, 0, sv);
6141 scan_formline(register char *s)
6146 SV *stuff = newSVpv("",0);
6147 bool needargs = FALSE;
6150 if (*s == '.' || *s == '}') {
6152 #ifdef PERL_STRICT_CR
6153 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6155 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6157 if (*t == '\n' || t == PL_bufend)
6160 if (PL_in_eval && !PL_rsfp) {
6161 eol = strchr(s,'\n');
6166 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6168 for (t = s; t < eol; t++) {
6169 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6171 goto enough; /* ~~ must be first line in formline */
6173 if (*t == '@' || *t == '^')
6176 sv_catpvn(stuff, s, eol-s);
6180 s = filter_gets(PL_linestr, PL_rsfp, 0);
6181 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6182 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6185 yyerror("Format not terminated");
6195 PL_lex_state = LEX_NORMAL;
6196 PL_nextval[PL_nexttoke].ival = 0;
6200 PL_lex_state = LEX_FORMLINE;
6201 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6203 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6207 SvREFCNT_dec(stuff);
6208 PL_lex_formbrack = 0;
6219 PL_cshlen = strlen(PL_cshname);
6224 start_subparse(I32 is_format, U32 flags)
6227 I32 oldsavestack_ix = PL_savestack_ix;
6228 CV* outsidecv = PL_compcv;
6232 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6234 save_I32(&PL_subline);
6235 save_item(PL_subname);
6237 SAVESPTR(PL_curpad);
6238 SAVESPTR(PL_comppad);
6239 SAVESPTR(PL_comppad_name);
6240 SAVESPTR(PL_compcv);
6241 SAVEI32(PL_comppad_name_fill);
6242 SAVEI32(PL_min_intro_pending);
6243 SAVEI32(PL_max_intro_pending);
6244 SAVEI32(PL_pad_reset_pending);
6246 PL_compcv = (CV*)NEWSV(1104,0);
6247 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6248 CvFLAGS(PL_compcv) |= flags;
6250 PL_comppad = newAV();
6251 av_push(PL_comppad, Nullsv);
6252 PL_curpad = AvARRAY(PL_comppad);
6253 PL_comppad_name = newAV();
6254 PL_comppad_name_fill = 0;
6255 PL_min_intro_pending = 0;
6257 PL_subline = PL_curcop->cop_line;
6259 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6260 PL_curpad[0] = (SV*)newAV();
6261 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6262 #endif /* USE_THREADS */
6264 comppadlist = newAV();
6265 AvREAL_off(comppadlist);
6266 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6267 av_store(comppadlist, 1, (SV*)PL_comppad);
6269 CvPADLIST(PL_compcv) = comppadlist;
6270 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6272 CvOWNER(PL_compcv) = 0;
6273 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6274 MUTEX_INIT(CvMUTEXP(PL_compcv));
6275 #endif /* USE_THREADS */
6277 return oldsavestack_ix;
6296 char *context = NULL;
6300 if (!yychar || (yychar == ';' && !PL_rsfp))
6302 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6303 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6304 while (isSPACE(*PL_oldoldbufptr))
6306 context = PL_oldoldbufptr;
6307 contlen = PL_bufptr - PL_oldoldbufptr;
6309 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6310 PL_oldbufptr != PL_bufptr) {
6311 while (isSPACE(*PL_oldbufptr))
6313 context = PL_oldbufptr;
6314 contlen = PL_bufptr - PL_oldbufptr;
6316 else if (yychar > 255)
6317 where = "next token ???";
6318 else if ((yychar & 127) == 127) {
6319 if (PL_lex_state == LEX_NORMAL ||
6320 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6321 where = "at end of line";
6322 else if (PL_lex_inpat)
6323 where = "within pattern";
6325 where = "within string";
6328 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6330 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6331 else if (isPRINT_LC(yychar))
6332 sv_catpvf(where_sv, "%c", yychar);
6334 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6335 where = SvPVX(where_sv);
6337 msg = sv_2mortal(newSVpv(s, 0));
6338 sv_catpvf(msg, " at %_ line %ld, ",
6339 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6341 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6343 sv_catpvf(msg, "%s\n", where);
6344 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6346 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6347 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6352 else if (PL_in_eval)
6353 sv_catsv(ERRSV, msg);
6355 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6356 if (++PL_error_count >= 10)
6357 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6359 PL_in_my_stash = Nullhv;