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;
119 #define yylval (*yylval_pointer)
120 #define yychar (*yychar_pointer)
121 #define YYLEXPARAM yylval_pointer,yychar_pointer
126 #include "keywords.h"
131 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
133 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
134 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
135 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
136 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
137 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
138 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
139 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
140 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
141 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
142 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
143 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
144 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
145 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
146 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
147 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
148 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
149 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
150 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
151 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
152 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
154 /* This bit of chicanery makes a unary function followed by
155 * a parenthesis into a function with one argument, highest precedence.
157 #define UNI(f) return(yylval.ival = f, \
160 PL_last_uni = PL_oldbufptr, \
161 PL_last_lop_op = f, \
162 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
164 #define UNIBRACK(f) return(yylval.ival = f, \
166 PL_last_uni = PL_oldbufptr, \
167 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
169 /* grandfather return to old style */
170 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
175 if (*PL_bufptr == '=') {
177 if (toketype == ANDAND)
178 yylval.ival = OP_ANDASSIGN;
179 else if (toketype == OROR)
180 yylval.ival = OP_ORASSIGN;
187 no_op(char *what, char *s)
189 char *oldbp = PL_bufptr;
190 bool is_first = (PL_oldbufptr == PL_linestart);
193 yywarn(form("%s found where operator expected", what));
195 warn("\t(Missing semicolon on previous line?)\n");
196 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
198 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
199 if (t < PL_bufptr && isSPACE(*t))
200 warn("\t(Do you need to predeclare %.*s?)\n",
201 t - PL_oldoldbufptr, PL_oldoldbufptr);
205 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
215 char *nl = strrchr(s,'\n');
221 iscntrl(PL_multi_close)
223 PL_multi_close < 32 || PL_multi_close == 127
227 tmpbuf[1] = toCTRL(PL_multi_close);
233 *tmpbuf = PL_multi_close;
237 q = strchr(s,'"') ? '\'' : '"';
238 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
245 if (ckWARN(WARN_DEPRECATED))
246 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
252 deprecate("comma-less variable list");
258 win32_textfilter(int idx, SV *sv, int maxlen)
260 I32 count = FILTER_READ(idx+1, sv, maxlen);
261 if (count > 0 && !maxlen)
262 win32_strip_return(sv);
270 utf16_textfilter(int idx, SV *sv, int maxlen)
272 I32 count = FILTER_READ(idx+1, sv, maxlen);
276 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
277 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
278 sv_usepvn(sv, (char*)tmps, tend - tmps);
285 utf16rev_textfilter(int idx, SV *sv, int maxlen)
287 I32 count = FILTER_READ(idx+1, sv, maxlen);
291 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
292 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
293 sv_usepvn(sv, (char*)tmps, tend - tmps);
308 SAVEI32(PL_lex_dojoin);
309 SAVEI32(PL_lex_brackets);
310 SAVEI32(PL_lex_fakebrack);
311 SAVEI32(PL_lex_casemods);
312 SAVEI32(PL_lex_starts);
313 SAVEI32(PL_lex_state);
314 SAVESPTR(PL_lex_inpat);
315 SAVEI32(PL_lex_inwhat);
316 SAVEI16(PL_curcop->cop_line);
319 SAVEPPTR(PL_oldbufptr);
320 SAVEPPTR(PL_oldoldbufptr);
321 SAVEPPTR(PL_linestart);
322 SAVESPTR(PL_linestr);
323 SAVEPPTR(PL_lex_brackstack);
324 SAVEPPTR(PL_lex_casestack);
325 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
326 SAVESPTR(PL_lex_stuff);
327 SAVEI32(PL_lex_defer);
328 SAVESPTR(PL_lex_repl);
329 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
330 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
332 PL_lex_state = LEX_NORMAL;
336 PL_lex_fakebrack = 0;
337 New(899, PL_lex_brackstack, 120, char);
338 New(899, PL_lex_casestack, 12, char);
339 SAVEFREEPV(PL_lex_brackstack);
340 SAVEFREEPV(PL_lex_casestack);
342 *PL_lex_casestack = '\0';
345 PL_lex_stuff = Nullsv;
346 PL_lex_repl = Nullsv;
350 if (SvREADONLY(PL_linestr))
351 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
352 s = SvPV(PL_linestr, len);
353 if (len && s[len-1] != ';') {
354 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
355 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
356 sv_catpvn(PL_linestr, "\n;", 2);
358 SvTEMP_off(PL_linestr);
359 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
360 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
362 PL_rs = newSVpv("\n", 1);
369 PL_doextract = FALSE;
373 restore_rsfp(void *f)
375 PerlIO *fp = (PerlIO*)f;
377 if (PL_rsfp == PerlIO_stdin())
378 PerlIO_clearerr(PL_rsfp);
379 else if (PL_rsfp && (PL_rsfp != fp))
380 PerlIO_close(PL_rsfp);
385 restore_expect(void *e)
387 /* a safe way to store a small integer in a pointer */
388 PL_expect = (expectation)((char *)e - PL_tokenbuf);
392 restore_lex_expect(void *e)
394 /* a safe way to store a small integer in a pointer */
395 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
407 PL_curcop->cop_line++;
410 while (*s == ' ' || *s == '\t') s++;
411 if (strnEQ(s, "line ", 5)) {
420 while (*s == ' ' || *s == '\t')
422 if (*s == '"' && (t = strchr(s+1, '"')))
426 return; /* false alarm */
427 for (t = s; !isSPACE(*t); t++) ;
432 PL_curcop->cop_filegv = gv_fetchfile(s);
434 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
436 PL_curcop->cop_line = atoi(n)-1;
440 skipspace(register char *s)
443 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
444 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
450 while (s < PL_bufend && isSPACE(*s))
452 if (s < PL_bufend && *s == '#') {
453 while (s < PL_bufend && *s != '\n')
458 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
460 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
461 if (PL_minus_n || PL_minus_p) {
462 sv_setpv(PL_linestr,PL_minus_p ?
463 ";}continue{print or die qq(-p destination: $!\\n)" :
465 sv_catpv(PL_linestr,";}");
466 PL_minus_n = PL_minus_p = 0;
469 sv_setpv(PL_linestr,";");
470 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
471 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
472 if (PL_preprocess && !PL_in_eval)
473 (void)PerlProc_pclose(PL_rsfp);
474 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
475 PerlIO_clearerr(PL_rsfp);
477 (void)PerlIO_close(PL_rsfp);
481 PL_linestart = PL_bufptr = s + prevlen;
482 PL_bufend = s + SvCUR(PL_linestr);
485 if (PERLDB_LINE && PL_curstash != PL_debstash) {
486 SV *sv = NEWSV(85,0);
488 sv_upgrade(sv, SVt_PVMG);
489 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
490 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
501 if (PL_oldoldbufptr != PL_last_uni)
503 while (isSPACE(*PL_last_uni))
505 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
506 if ((t = strchr(s, '(')) && t < PL_bufptr)
510 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
517 #define UNI(f) return uni(f,s)
525 PL_last_uni = PL_oldbufptr;
536 #endif /* CRIPPLED_CC */
538 #define LOP(f,x) return lop(f,x,s)
541 lop(I32 f, expectation x, char *s)
548 PL_last_lop = PL_oldbufptr;
564 PL_nexttype[PL_nexttoke] = type;
566 if (PL_lex_state != LEX_KNOWNEXT) {
567 PL_lex_defer = PL_lex_state;
568 PL_lex_expect = PL_expect;
569 PL_lex_state = LEX_KNOWNEXT;
574 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
579 start = skipspace(start);
581 if (isIDFIRST_lazy(s) ||
582 (allow_pack && *s == ':') ||
583 (allow_initial_tick && *s == '\'') )
585 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
586 if (check_keyword && keyword(PL_tokenbuf, len))
588 if (token == METHOD) {
593 PL_expect = XOPERATOR;
598 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
599 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
606 force_ident(register char *s, int kind)
609 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
610 PL_nextval[PL_nexttoke].opval = o;
613 dTHR; /* just for in_eval */
614 o->op_private = OPpCONST_ENTERED;
615 /* XXX see note in pp_entereval() for why we forgo typo
616 warnings if the symbol must be introduced in an eval.
618 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
619 kind == '$' ? SVt_PV :
620 kind == '@' ? SVt_PVAV :
621 kind == '%' ? SVt_PVHV :
629 force_version(char *s)
631 OP *version = Nullop;
635 /* default VERSION number -- GBARR */
640 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
641 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
643 /* real VERSION number -- GBARR */
644 version = yylval.opval;
648 /* NOTE: The parser sees the package name and the VERSION swapped */
649 PL_nextval[PL_nexttoke].opval = version;
667 s = SvPV_force(sv, len);
671 while (s < send && *s != '\\')
676 if ( PL_hints & HINT_NEW_STRING )
677 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
680 if (s + 1 < send && (s[1] == '\\'))
681 s++; /* all that, just for this */
686 SvCUR_set(sv, d - SvPVX(sv));
688 if ( PL_hints & HINT_NEW_STRING )
689 return new_constant(NULL, 0, "q", sv, pv, "q");
696 register I32 op_type = yylval.ival;
698 if (op_type == OP_NULL) {
699 yylval.opval = PL_lex_op;
703 if (op_type == OP_CONST || op_type == OP_READLINE) {
704 SV *sv = tokeq(PL_lex_stuff);
706 if (SvTYPE(sv) == SVt_PVIV) {
707 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
713 nsv = newSVpv(p, len);
717 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
718 PL_lex_stuff = Nullsv;
722 PL_sublex_info.super_state = PL_lex_state;
723 PL_sublex_info.sub_inwhat = op_type;
724 PL_sublex_info.sub_op = PL_lex_op;
725 PL_lex_state = LEX_INTERPPUSH;
729 yylval.opval = PL_lex_op;
743 PL_lex_state = PL_sublex_info.super_state;
744 SAVEI32(PL_lex_dojoin);
745 SAVEI32(PL_lex_brackets);
746 SAVEI32(PL_lex_fakebrack);
747 SAVEI32(PL_lex_casemods);
748 SAVEI32(PL_lex_starts);
749 SAVEI32(PL_lex_state);
750 SAVESPTR(PL_lex_inpat);
751 SAVEI32(PL_lex_inwhat);
752 SAVEI16(PL_curcop->cop_line);
754 SAVEPPTR(PL_oldbufptr);
755 SAVEPPTR(PL_oldoldbufptr);
756 SAVEPPTR(PL_linestart);
757 SAVESPTR(PL_linestr);
758 SAVEPPTR(PL_lex_brackstack);
759 SAVEPPTR(PL_lex_casestack);
761 PL_linestr = PL_lex_stuff;
762 PL_lex_stuff = Nullsv;
764 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
765 PL_bufend += SvCUR(PL_linestr);
766 SAVEFREESV(PL_linestr);
768 PL_lex_dojoin = FALSE;
770 PL_lex_fakebrack = 0;
771 New(899, PL_lex_brackstack, 120, char);
772 New(899, PL_lex_casestack, 12, char);
773 SAVEFREEPV(PL_lex_brackstack);
774 SAVEFREEPV(PL_lex_casestack);
776 *PL_lex_casestack = '\0';
778 PL_lex_state = LEX_INTERPCONCAT;
779 PL_curcop->cop_line = PL_multi_start;
781 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
782 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
783 PL_lex_inpat = PL_sublex_info.sub_op;
785 PL_lex_inpat = Nullop;
793 if (!PL_lex_starts++) {
794 PL_expect = XOPERATOR;
795 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
799 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
800 PL_lex_state = LEX_INTERPCASEMOD;
801 return yylex(YYLEXPARAM);
804 /* Is there a right-hand side to take care of? */
805 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
806 PL_linestr = PL_lex_repl;
808 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
809 PL_bufend += SvCUR(PL_linestr);
810 SAVEFREESV(PL_linestr);
811 PL_lex_dojoin = FALSE;
813 PL_lex_fakebrack = 0;
815 *PL_lex_casestack = '\0';
817 if (SvCOMPILED(PL_lex_repl)) {
818 PL_lex_state = LEX_INTERPNORMAL;
822 PL_lex_state = LEX_INTERPCONCAT;
823 PL_lex_repl = Nullsv;
828 PL_bufend = SvPVX(PL_linestr);
829 PL_bufend += SvCUR(PL_linestr);
830 PL_expect = XOPERATOR;
838 Extracts a pattern, double-quoted string, or transliteration. This
841 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
842 processing a pattern (PL_lex_inpat is true), a transliteration
843 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
845 Returns a pointer to the character scanned up to. Iff this is
846 advanced from the start pointer supplied (ie if anything was
847 successfully parsed), will leave an OP for the substring scanned
848 in yylval. Caller must intuit reason for not parsing further
849 by looking at the next characters herself.
853 double-quoted style: \r and \n
854 regexp special ones: \D \s
856 backrefs: \1 (deprecated in substitution replacements)
857 case and quoting: \U \Q \E
858 stops on @ and $, but not for $ as tail anchor
861 characters are VERY literal, except for - not at the start or end
862 of the string, which indicates a range. scan_const expands the
863 range to the full set of intermediate characters.
865 In double-quoted strings:
867 double-quoted style: \r and \n
869 backrefs: \1 (deprecated)
870 case and quoting: \U \Q \E
873 scan_const does *not* construct ops to handle interpolated strings.
874 It stops processing as soon as it finds an embedded $ or @ variable
875 and leaves it to the caller to work out what's going on.
877 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
879 $ in pattern could be $foo or could be tail anchor. Assumption:
880 it's a tail anchor if $ is the last thing in the string, or if it's
881 followed by one of ")| \n\t"
883 \1 (backreferences) are turned into $1
885 The structure of the code is
886 while (there's a character to process) {
887 handle transliteration ranges
889 skip # initiated comments in //x patterns
890 check for embedded @foo
891 check for embedded scalars
893 leave intact backslashes from leave (below)
894 deprecate \1 in strings and sub replacements
895 handle string-changing backslashes \l \U \Q \E, etc.
896 switch (what was escaped) {
897 handle - in a transliteration (becomes a literal -)
898 handle \132 octal characters
899 handle 0x15 hex characters
900 handle \cV (control V)
901 handle printf backslashes (\f, \r, \n, etc)
904 } (end while character to read)
909 scan_const(char *start)
911 register char *send = PL_bufend; /* end of the constant */
912 SV *sv = NEWSV(93, send - start); /* sv for the constant */
913 register char *s = start; /* start of the constant */
914 register char *d = SvPVX(sv); /* destination for copies */
915 bool dorange = FALSE; /* are we in a translit range? */
917 I32 utf = PL_lex_inwhat == OP_TRANS
918 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
920 I32 thisutf = PL_lex_inwhat == OP_TRANS
921 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
924 /* leaveit is the set of acceptably-backslashed characters */
927 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
930 while (s < send || dorange) {
931 /* get transliterations out of the way (they're most literal) */
932 if (PL_lex_inwhat == OP_TRANS) {
933 /* expand a range A-Z to the full set of characters. AIE! */
935 I32 i; /* current expanded character */
936 I32 min; /* first character in range */
937 I32 max; /* last character in range */
939 i = d - SvPVX(sv); /* remember current offset */
940 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
941 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
942 d -= 2; /* eat the first char and the - */
944 min = (U8)*d; /* first char in range */
945 max = (U8)d[1]; /* last char in range */
948 if ((isLOWER(min) && isLOWER(max)) ||
949 (isUPPER(min) && isUPPER(max))) {
951 for (i = min; i <= max; i++)
955 for (i = min; i <= max; i++)
962 for (i = min; i <= max; i++)
965 /* mark the range as done, and continue */
970 /* range begins (ignore - as first or last char) */
971 else if (*s == '-' && s+1 < send && s != start) {
973 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
982 /* if we get here, we're not doing a transliteration */
984 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
985 except for the last char, which will be done separately. */
986 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
988 while (s < send && *s != ')')
990 } else if (s[2] == '{'
991 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
993 char *regparse = s + (s[2] == '{' ? 3 : 4);
996 while (count && (c = *regparse)) {
997 if (c == '\\' && regparse[1])
1005 if (*regparse != ')') {
1006 regparse--; /* Leave one char for continuation. */
1007 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1009 while (s < regparse)
1014 /* likewise skip #-initiated comments in //x patterns */
1015 else if (*s == '#' && PL_lex_inpat &&
1016 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1017 while (s+1 < send && *s != '\n')
1021 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1022 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1025 /* check for embedded scalars. only stop if we're sure it's a
1028 else if (*s == '$') {
1029 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1031 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1032 break; /* in regexp, $ might be tail anchor */
1035 /* (now in tr/// code again) */
1037 if (*s & 0x80 && thisutf) {
1038 dTHR; /* only for ckWARN */
1039 if (ckWARN(WARN_UTF8)) {
1040 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1050 if (*s == '\\' && s+1 < send) {
1053 /* some backslashes we leave behind */
1054 if (*s && strchr(leaveit, *s)) {
1060 /* deprecate \1 in strings and substitution replacements */
1061 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1062 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1064 dTHR; /* only for ckWARN */
1065 if (ckWARN(WARN_SYNTAX))
1066 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1071 /* string-change backslash escapes */
1072 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1077 /* if we get here, it's either a quoted -, or a digit */
1080 /* quoted - in transliterations */
1082 if (PL_lex_inwhat == OP_TRANS) {
1087 /* default action is to copy the quoted character */
1092 /* \132 indicates an octal constant */
1093 case '0': case '1': case '2': case '3':
1094 case '4': case '5': case '6': case '7':
1095 *d++ = scan_oct(s, 3, &len);
1099 /* \x24 indicates a hex constant */
1103 char* e = strchr(s, '}');
1106 yyerror("Missing right brace on \\x{}");
1111 if (ckWARN(WARN_UTF8))
1113 "Use of \\x{} without utf8 declaration");
1115 /* note: utf always shorter than hex */
1116 d = (char*)uv_to_utf8((U8*)d,
1117 scan_hex(s + 1, e - s - 1, &len));
1122 UV uv = (UV)scan_hex(s, 2, &len);
1123 if (utf && PL_lex_inwhat == OP_TRANS &&
1124 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1126 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1129 if (uv >= 127 && UTF) {
1131 if (ckWARN(WARN_UTF8))
1133 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1142 /* \c is a control character */
1156 /* printf-style backslashes, formfeeds, newlines, etc */
1182 } /* end if (backslash) */
1185 } /* while loop to process each character */
1187 /* terminate the string and set up the sv */
1189 SvCUR_set(sv, d - SvPVX(sv));
1192 /* shrink the sv if we allocated more than we used */
1193 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1194 SvLEN_set(sv, SvCUR(sv) + 1);
1195 Renew(SvPVX(sv), SvLEN(sv), char);
1198 /* return the substring (via yylval) only if we parsed anything */
1199 if (s > PL_bufptr) {
1200 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1201 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1203 ( PL_lex_inwhat == OP_TRANS
1205 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1208 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1214 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1216 intuit_more(register char *s)
1218 if (PL_lex_brackets)
1220 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1222 if (*s != '{' && *s != '[')
1227 /* In a pattern, so maybe we have {n,m}. */
1244 /* On the other hand, maybe we have a character class */
1247 if (*s == ']' || *s == '^')
1250 int weight = 2; /* let's weigh the evidence */
1252 unsigned char un_char = 255, last_un_char;
1253 char *send = strchr(s,']');
1254 char tmpbuf[sizeof PL_tokenbuf * 4];
1256 if (!send) /* has to be an expression */
1259 Zero(seen,256,char);
1262 else if (isDIGIT(*s)) {
1264 if (isDIGIT(s[1]) && s[2] == ']')
1270 for (; s < send; s++) {
1271 last_un_char = un_char;
1272 un_char = (unsigned char)*s;
1277 weight -= seen[un_char] * 10;
1278 if (isALNUM_lazy(s+1)) {
1279 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1280 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1285 else if (*s == '$' && s[1] &&
1286 strchr("[#!%*<>()-=",s[1])) {
1287 if (/*{*/ strchr("])} =",s[2]))
1296 if (strchr("wds]",s[1]))
1298 else if (seen['\''] || seen['"'])
1300 else if (strchr("rnftbxcav",s[1]))
1302 else if (isDIGIT(s[1])) {
1304 while (s[1] && isDIGIT(s[1]))
1314 if (strchr("aA01! ",last_un_char))
1316 if (strchr("zZ79~",s[1]))
1318 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1319 weight -= 5; /* cope with negative subscript */
1322 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1323 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1328 if (keyword(tmpbuf, d - tmpbuf))
1331 if (un_char == last_un_char + 1)
1333 weight -= seen[un_char];
1338 if (weight >= 0) /* probably a character class */
1346 intuit_method(char *start, GV *gv)
1348 char *s = start + (*start == '$');
1349 char tmpbuf[sizeof PL_tokenbuf];
1357 if ((cv = GvCVu(gv))) {
1358 char *proto = SvPVX(cv);
1368 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1369 if (*start == '$') {
1370 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1375 return *s == '(' ? FUNCMETH : METHOD;
1377 if (!keyword(tmpbuf, len)) {
1378 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1383 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1384 if (indirgv && GvCVu(indirgv))
1386 /* filehandle or package name makes it a method */
1387 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1389 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1390 return 0; /* no assumptions -- "=>" quotes bearword */
1392 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1394 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1398 return *s == '(' ? FUNCMETH : METHOD;
1408 char *pdb = PerlEnv_getenv("PERL5DB");
1412 SETERRNO(0,SS$_NORMAL);
1413 return "BEGIN { require 'perl5db.pl' }";
1419 /* Encoded script support. filter_add() effectively inserts a
1420 * 'pre-processing' function into the current source input stream.
1421 * Note that the filter function only applies to the current source file
1422 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1424 * The datasv parameter (which may be NULL) can be used to pass
1425 * private data to this instance of the filter. The filter function
1426 * can recover the SV using the FILTER_DATA macro and use it to
1427 * store private buffers and state information.
1429 * The supplied datasv parameter is upgraded to a PVIO type
1430 * and the IoDIRP field is used to store the function pointer.
1431 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1432 * private use must be set using malloc'd pointers.
1434 static int filter_debug = 0;
1437 filter_add(filter_t funcp, SV *datasv)
1439 if (!funcp){ /* temporary handy debugging hack to be deleted */
1440 filter_debug = atoi((char*)datasv);
1443 if (!PL_rsfp_filters)
1444 PL_rsfp_filters = newAV();
1446 datasv = NEWSV(255,0);
1447 if (!SvUPGRADE(datasv, SVt_PVIO))
1448 die("Can't upgrade filter_add data to SVt_PVIO");
1449 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1451 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1452 av_unshift(PL_rsfp_filters, 1);
1453 av_store(PL_rsfp_filters, 0, datasv) ;
1458 /* Delete most recently added instance of this filter function. */
1460 filter_del(filter_t funcp)
1463 warn("filter_del func %p", funcp);
1464 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1466 /* if filter is on top of stack (usual case) just pop it off */
1467 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1468 sv_free(av_pop(PL_rsfp_filters));
1472 /* we need to search for the correct entry and clear it */
1473 die("filter_del can only delete in reverse order (currently)");
1477 /* Invoke the n'th filter function for the current rsfp. */
1479 filter_read(int idx, SV *buf_sv, int maxlen)
1482 /* 0 = read one text line */
1487 if (!PL_rsfp_filters)
1489 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1490 /* Provide a default input filter to make life easy. */
1491 /* Note that we append to the line. This is handy. */
1493 warn("filter_read %d: from rsfp\n", idx);
1497 int old_len = SvCUR(buf_sv) ;
1499 /* ensure buf_sv is large enough */
1500 SvGROW(buf_sv, old_len + maxlen) ;
1501 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1502 if (PerlIO_error(PL_rsfp))
1503 return -1; /* error */
1505 return 0 ; /* end of file */
1507 SvCUR_set(buf_sv, old_len + len) ;
1510 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1511 if (PerlIO_error(PL_rsfp))
1512 return -1; /* error */
1514 return 0 ; /* end of file */
1517 return SvCUR(buf_sv);
1519 /* Skip this filter slot if filter has been deleted */
1520 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1522 warn("filter_read %d: skipped (filter deleted)\n", idx);
1523 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1525 /* Get function pointer hidden within datasv */
1526 funcp = (filter_t)IoDIRP(datasv);
1528 warn("filter_read %d: via function %p (%s)\n",
1529 idx, funcp, SvPV(datasv,PL_na));
1530 /* Call function. The function is expected to */
1531 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1532 /* Return: <0:error, =0:eof, >0:not eof */
1533 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1537 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1540 if (!PL_rsfp_filters) {
1541 filter_add(win32_textfilter,NULL);
1544 if (PL_rsfp_filters) {
1547 SvCUR_set(sv, 0); /* start with empty line */
1548 if (FILTER_READ(0, sv, 0) > 0)
1549 return ( SvPVX(sv) ) ;
1554 return (sv_gets(sv, fp, append));
1559 static char* exp_name[] =
1560 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1566 Works out what to call the token just pulled out of the input
1567 stream. The yacc parser takes care of taking the ops we return and
1568 stitching them into a tree.
1574 if read an identifier
1575 if we're in a my declaration
1576 croak if they tried to say my($foo::bar)
1577 build the ops for a my() declaration
1578 if it's an access to a my() variable
1579 are we in a sort block?
1580 croak if my($a); $a <=> $b
1581 build ops for access to a my() variable
1582 if in a dq string, and they've said @foo and we can't find @foo
1584 build ops for a bareword
1585 if we already built the token before, use it.
1589 #ifdef USE_PURE_BISON
1590 (YYSTYPE* lvalp, int* lcharp)
1603 #ifdef USE_PURE_BISON
1604 yylval_pointer = lvalp;
1605 yychar_pointer = lcharp;
1608 /* check if there's an identifier for us to look at */
1609 if (PL_pending_ident) {
1610 /* pit holds the identifier we read and pending_ident is reset */
1611 char pit = PL_pending_ident;
1612 PL_pending_ident = 0;
1614 /* if we're in a my(), we can't allow dynamics here.
1615 $foo'bar has already been turned into $foo::bar, so
1616 just check for colons.
1618 if it's a legal name, the OP is a PADANY.
1621 if (strchr(PL_tokenbuf,':'))
1622 croak(no_myglob,PL_tokenbuf);
1624 yylval.opval = newOP(OP_PADANY, 0);
1625 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1630 build the ops for accesses to a my() variable.
1632 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1633 then used in a comparison. This catches most, but not
1634 all cases. For instance, it catches
1635 sort { my($a); $a <=> $b }
1637 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1638 (although why you'd do that is anyone's guess).
1641 if (!strchr(PL_tokenbuf,':')) {
1643 /* Check for single character per-thread SVs */
1644 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1645 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1646 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1648 yylval.opval = newOP(OP_THREADSV, 0);
1649 yylval.opval->op_targ = tmp;
1652 #endif /* USE_THREADS */
1653 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1654 /* if it's a sort block and they're naming $a or $b */
1655 if (PL_last_lop_op == OP_SORT &&
1656 PL_tokenbuf[0] == '$' &&
1657 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1660 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1661 d < PL_bufend && *d != '\n';
1664 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1665 croak("Can't use \"my %s\" in sort comparison",
1671 yylval.opval = newOP(OP_PADANY, 0);
1672 yylval.opval->op_targ = tmp;
1678 Whine if they've said @foo in a doublequoted string,
1679 and @foo isn't a variable we can find in the symbol
1682 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1683 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1684 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1685 yyerror(form("In string, %s now must be written as \\%s",
1686 PL_tokenbuf, PL_tokenbuf));
1689 /* build ops for a bareword */
1690 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1691 yylval.opval->op_private = OPpCONST_ENTERED;
1692 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1693 ((PL_tokenbuf[0] == '$') ? SVt_PV
1694 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1699 /* no identifier pending identification */
1701 switch (PL_lex_state) {
1703 case LEX_NORMAL: /* Some compilers will produce faster */
1704 case LEX_INTERPNORMAL: /* code if we comment these out. */
1708 /* when we're already built the next token, just pull it out the queue */
1711 yylval = PL_nextval[PL_nexttoke];
1713 PL_lex_state = PL_lex_defer;
1714 PL_expect = PL_lex_expect;
1715 PL_lex_defer = LEX_NORMAL;
1717 return(PL_nexttype[PL_nexttoke]);
1719 /* interpolated case modifiers like \L \U, including \Q and \E.
1720 when we get here, PL_bufptr is at the \
1722 case LEX_INTERPCASEMOD:
1724 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1725 croak("panic: INTERPCASEMOD");
1727 /* handle \E or end of string */
1728 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1732 if (PL_lex_casemods) {
1733 oldmod = PL_lex_casestack[--PL_lex_casemods];
1734 PL_lex_casestack[PL_lex_casemods] = '\0';
1736 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1738 PL_lex_state = LEX_INTERPCONCAT;
1742 if (PL_bufptr != PL_bufend)
1744 PL_lex_state = LEX_INTERPCONCAT;
1745 return yylex(YYLEXPARAM);
1749 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1750 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1751 if (strchr("LU", *s) &&
1752 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1754 PL_lex_casestack[--PL_lex_casemods] = '\0';
1757 if (PL_lex_casemods > 10) {
1758 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1759 if (newlb != PL_lex_casestack) {
1761 PL_lex_casestack = newlb;
1764 PL_lex_casestack[PL_lex_casemods++] = *s;
1765 PL_lex_casestack[PL_lex_casemods] = '\0';
1766 PL_lex_state = LEX_INTERPCONCAT;
1767 PL_nextval[PL_nexttoke].ival = 0;
1770 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1772 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1774 PL_nextval[PL_nexttoke].ival = OP_LC;
1776 PL_nextval[PL_nexttoke].ival = OP_UC;
1778 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1780 croak("panic: yylex");
1783 if (PL_lex_starts) {
1789 return yylex(YYLEXPARAM);
1792 case LEX_INTERPPUSH:
1793 return sublex_push();
1795 case LEX_INTERPSTART:
1796 if (PL_bufptr == PL_bufend)
1797 return sublex_done();
1799 PL_lex_dojoin = (*PL_bufptr == '@');
1800 PL_lex_state = LEX_INTERPNORMAL;
1801 if (PL_lex_dojoin) {
1802 PL_nextval[PL_nexttoke].ival = 0;
1805 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1806 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1807 force_next(PRIVATEREF);
1809 force_ident("\"", '$');
1810 #endif /* USE_THREADS */
1811 PL_nextval[PL_nexttoke].ival = 0;
1813 PL_nextval[PL_nexttoke].ival = 0;
1815 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1818 if (PL_lex_starts++) {
1822 return yylex(YYLEXPARAM);
1824 case LEX_INTERPENDMAYBE:
1825 if (intuit_more(PL_bufptr)) {
1826 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1832 if (PL_lex_dojoin) {
1833 PL_lex_dojoin = FALSE;
1834 PL_lex_state = LEX_INTERPCONCAT;
1838 case LEX_INTERPCONCAT:
1840 if (PL_lex_brackets)
1841 croak("panic: INTERPCONCAT");
1843 if (PL_bufptr == PL_bufend)
1844 return sublex_done();
1846 if (SvIVX(PL_linestr) == '\'') {
1847 SV *sv = newSVsv(PL_linestr);
1850 else if ( PL_hints & HINT_NEW_RE )
1851 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1852 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1856 s = scan_const(PL_bufptr);
1858 PL_lex_state = LEX_INTERPCASEMOD;
1860 PL_lex_state = LEX_INTERPSTART;
1863 if (s != PL_bufptr) {
1864 PL_nextval[PL_nexttoke] = yylval;
1867 if (PL_lex_starts++)
1871 return yylex(YYLEXPARAM);
1875 return yylex(YYLEXPARAM);
1877 PL_lex_state = LEX_NORMAL;
1878 s = scan_formline(PL_bufptr);
1879 if (!PL_lex_formbrack)
1885 PL_oldoldbufptr = PL_oldbufptr;
1888 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1894 if (isIDFIRST_lazy(s))
1896 croak("Unrecognized character \\x%02X", *s & 255);
1899 goto fake_eof; /* emulate EOF on ^D or ^Z */
1904 if (PL_lex_brackets)
1905 yyerror("Missing right bracket");
1908 if (s++ < PL_bufend)
1909 goto retry; /* ignore stray nulls */
1912 if (!PL_in_eval && !PL_preambled) {
1913 PL_preambled = TRUE;
1914 sv_setpv(PL_linestr,incl_perldb());
1915 if (SvCUR(PL_linestr))
1916 sv_catpv(PL_linestr,";");
1918 while(AvFILLp(PL_preambleav) >= 0) {
1919 SV *tmpsv = av_shift(PL_preambleav);
1920 sv_catsv(PL_linestr, tmpsv);
1921 sv_catpv(PL_linestr, ";");
1924 sv_free((SV*)PL_preambleav);
1925 PL_preambleav = NULL;
1927 if (PL_minus_n || PL_minus_p) {
1928 sv_catpv(PL_linestr, "LINE: while (<>) {");
1930 sv_catpv(PL_linestr,"chomp;");
1932 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1934 GvIMPORTED_AV_on(gv);
1936 if (strchr("/'\"", *PL_splitstr)
1937 && strchr(PL_splitstr + 1, *PL_splitstr))
1938 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1941 s = "'~#\200\1'"; /* surely one char is unused...*/
1942 while (s[1] && strchr(PL_splitstr, *s)) s++;
1944 sv_catpvf(PL_linestr, "@F=split(%s%c",
1945 "q" + (delim == '\''), delim);
1946 for (s = PL_splitstr; *s; s++) {
1948 sv_catpvn(PL_linestr, "\\", 1);
1949 sv_catpvn(PL_linestr, s, 1);
1951 sv_catpvf(PL_linestr, "%c);", delim);
1955 sv_catpv(PL_linestr,"@F=split(' ');");
1958 sv_catpv(PL_linestr, "\n");
1959 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1960 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1961 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1962 SV *sv = NEWSV(85,0);
1964 sv_upgrade(sv, SVt_PVMG);
1965 sv_setsv(sv,PL_linestr);
1966 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1971 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1974 if (PL_preprocess && !PL_in_eval)
1975 (void)PerlProc_pclose(PL_rsfp);
1976 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1977 PerlIO_clearerr(PL_rsfp);
1979 (void)PerlIO_close(PL_rsfp);
1981 PL_doextract = FALSE;
1983 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1984 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1985 sv_catpv(PL_linestr,";}");
1986 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1987 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1988 PL_minus_n = PL_minus_p = 0;
1991 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1992 sv_setpv(PL_linestr,"");
1993 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1996 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1997 PL_doextract = FALSE;
1999 /* Incest with pod. */
2000 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2001 sv_setpv(PL_linestr, "");
2002 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2003 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2004 PL_doextract = FALSE;
2008 } while (PL_doextract);
2009 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2010 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2011 SV *sv = NEWSV(85,0);
2013 sv_upgrade(sv, SVt_PVMG);
2014 sv_setsv(sv,PL_linestr);
2015 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2017 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2018 if (PL_curcop->cop_line == 1) {
2019 while (s < PL_bufend && isSPACE(*s))
2021 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2025 if (*s == '#' && *(s+1) == '!')
2027 #ifdef ALTERNATE_SHEBANG
2029 static char as[] = ALTERNATE_SHEBANG;
2030 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2031 d = s + (sizeof(as) - 1);
2033 #endif /* ALTERNATE_SHEBANG */
2042 while (*d && !isSPACE(*d))
2046 #ifdef ARG_ZERO_IS_SCRIPT
2047 if (ipathend > ipath) {
2049 * HP-UX (at least) sets argv[0] to the script name,
2050 * which makes $^X incorrect. And Digital UNIX and Linux,
2051 * at least, set argv[0] to the basename of the Perl
2052 * interpreter. So, having found "#!", we'll set it right.
2054 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2055 assert(SvPOK(x) || SvGMAGICAL(x));
2056 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2057 sv_setpvn(x, ipath, ipathend - ipath);
2060 TAINT_NOT; /* $^X is always tainted, but that's OK */
2062 #endif /* ARG_ZERO_IS_SCRIPT */
2067 d = instr(s,"perl -");
2069 d = instr(s,"perl");
2070 #ifdef ALTERNATE_SHEBANG
2072 * If the ALTERNATE_SHEBANG on this system starts with a
2073 * character that can be part of a Perl expression, then if
2074 * we see it but not "perl", we're probably looking at the
2075 * start of Perl code, not a request to hand off to some
2076 * other interpreter. Similarly, if "perl" is there, but
2077 * not in the first 'word' of the line, we assume the line
2078 * contains the start of the Perl program.
2080 if (d && *s != '#') {
2082 while (*c && !strchr("; \t\r\n\f\v#", *c))
2085 d = Nullch; /* "perl" not in first word; ignore */
2087 *s = '#'; /* Don't try to parse shebang line */
2089 #endif /* ALTERNATE_SHEBANG */
2094 !instr(s,"indir") &&
2095 instr(PL_origargv[0],"perl"))
2101 while (s < PL_bufend && isSPACE(*s))
2103 if (s < PL_bufend) {
2104 Newz(899,newargv,PL_origargc+3,char*);
2106 while (s < PL_bufend && !isSPACE(*s))
2109 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2112 newargv = PL_origargv;
2114 execv(ipath, newargv);
2115 croak("Can't exec %s", ipath);
2118 U32 oldpdb = PL_perldb;
2119 bool oldn = PL_minus_n;
2120 bool oldp = PL_minus_p;
2122 while (*d && !isSPACE(*d)) d++;
2123 while (*d == ' ' || *d == '\t') d++;
2127 if (*d == 'M' || *d == 'm') {
2129 while (*d && !isSPACE(*d)) d++;
2130 croak("Too late for \"-%.*s\" option",
2133 d = moreswitches(d);
2135 if (PERLDB_LINE && !oldpdb ||
2136 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2137 /* if we have already added "LINE: while (<>) {",
2138 we must not do it again */
2140 sv_setpv(PL_linestr, "");
2141 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2142 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2143 PL_preambled = FALSE;
2145 (void)gv_fetchfile(PL_origfilename);
2152 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2154 PL_lex_state = LEX_FORMLINE;
2155 return yylex(YYLEXPARAM);
2159 #ifdef PERL_STRICT_CR
2160 warn("Illegal character \\%03o (carriage return)", '\r');
2162 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2164 case ' ': case '\t': case '\f': case 013:
2169 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2171 while (s < d && *s != '\n')
2176 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2178 PL_lex_state = LEX_FORMLINE;
2179 return yylex(YYLEXPARAM);
2188 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2193 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2196 if (strnEQ(s,"=>",2)) {
2197 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2198 OPERATOR('-'); /* unary minus */
2200 PL_last_uni = PL_oldbufptr;
2201 PL_last_lop_op = OP_FTEREAD; /* good enough */
2203 case 'r': FTST(OP_FTEREAD);
2204 case 'w': FTST(OP_FTEWRITE);
2205 case 'x': FTST(OP_FTEEXEC);
2206 case 'o': FTST(OP_FTEOWNED);
2207 case 'R': FTST(OP_FTRREAD);
2208 case 'W': FTST(OP_FTRWRITE);
2209 case 'X': FTST(OP_FTREXEC);
2210 case 'O': FTST(OP_FTROWNED);
2211 case 'e': FTST(OP_FTIS);
2212 case 'z': FTST(OP_FTZERO);
2213 case 's': FTST(OP_FTSIZE);
2214 case 'f': FTST(OP_FTFILE);
2215 case 'd': FTST(OP_FTDIR);
2216 case 'l': FTST(OP_FTLINK);
2217 case 'p': FTST(OP_FTPIPE);
2218 case 'S': FTST(OP_FTSOCK);
2219 case 'u': FTST(OP_FTSUID);
2220 case 'g': FTST(OP_FTSGID);
2221 case 'k': FTST(OP_FTSVTX);
2222 case 'b': FTST(OP_FTBLK);
2223 case 'c': FTST(OP_FTCHR);
2224 case 't': FTST(OP_FTTTY);
2225 case 'T': FTST(OP_FTTEXT);
2226 case 'B': FTST(OP_FTBINARY);
2227 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2228 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2229 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2231 croak("Unrecognized file test: -%c", (int)tmp);
2238 if (PL_expect == XOPERATOR)
2243 else if (*s == '>') {
2246 if (isIDFIRST_lazy(s)) {
2247 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2255 if (PL_expect == XOPERATOR)
2258 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2260 OPERATOR('-'); /* unary minus */
2267 if (PL_expect == XOPERATOR)
2272 if (PL_expect == XOPERATOR)
2275 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2281 if (PL_expect != XOPERATOR) {
2282 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2283 PL_expect = XOPERATOR;
2284 force_ident(PL_tokenbuf, '*');
2297 if (PL_expect == XOPERATOR) {
2301 PL_tokenbuf[0] = '%';
2302 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2303 if (!PL_tokenbuf[1]) {
2305 yyerror("Final % should be \\% or %name");
2308 PL_pending_ident = '%';
2330 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2331 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2336 if (PL_curcop->cop_line < PL_copline)
2337 PL_copline = PL_curcop->cop_line;
2348 if (PL_lex_brackets <= 0)
2349 yyerror("Unmatched right bracket");
2352 if (PL_lex_state == LEX_INTERPNORMAL) {
2353 if (PL_lex_brackets == 0) {
2354 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2355 PL_lex_state = LEX_INTERPEND;
2362 if (PL_lex_brackets > 100) {
2363 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2364 if (newlb != PL_lex_brackstack) {
2366 PL_lex_brackstack = newlb;
2369 switch (PL_expect) {
2371 if (PL_lex_formbrack) {
2375 if (PL_oldoldbufptr == PL_last_lop)
2376 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2378 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2379 OPERATOR(HASHBRACK);
2381 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2384 PL_tokenbuf[0] = '\0';
2385 if (d < PL_bufend && *d == '-') {
2386 PL_tokenbuf[0] = '-';
2388 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2391 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2392 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2394 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2397 char minus = (PL_tokenbuf[0] == '-');
2398 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2405 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2409 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2414 if (PL_oldoldbufptr == PL_last_lop)
2415 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2417 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2420 OPERATOR(HASHBRACK);
2421 /* This hack serves to disambiguate a pair of curlies
2422 * as being a block or an anon hash. Normally, expectation
2423 * determines that, but in cases where we're not in a
2424 * position to expect anything in particular (like inside
2425 * eval"") we have to resolve the ambiguity. This code
2426 * covers the case where the first term in the curlies is a
2427 * quoted string. Most other cases need to be explicitly
2428 * disambiguated by prepending a `+' before the opening
2429 * curly in order to force resolution as an anon hash.
2431 * XXX should probably propagate the outer expectation
2432 * into eval"" to rely less on this hack, but that could
2433 * potentially break current behavior of eval"".
2437 if (*s == '\'' || *s == '"' || *s == '`') {
2438 /* common case: get past first string, handling escapes */
2439 for (t++; t < PL_bufend && *t != *s;)
2440 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2444 else if (*s == 'q') {
2447 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2448 && !isALNUM(*t)))) {
2450 char open, close, term;
2453 while (t < PL_bufend && isSPACE(*t))
2457 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2461 for (t++; t < PL_bufend; t++) {
2462 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2464 else if (*t == open)
2468 for (t++; t < PL_bufend; t++) {
2469 if (*t == '\\' && t+1 < PL_bufend)
2471 else if (*t == close && --brackets <= 0)
2473 else if (*t == open)
2479 else if (isIDFIRST_lazy(s)) {
2480 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2482 while (t < PL_bufend && isSPACE(*t))
2484 /* if comma follows first term, call it an anon hash */
2485 /* XXX it could be a comma expression with loop modifiers */
2486 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2487 || (*t == '=' && t[1] == '>')))
2488 OPERATOR(HASHBRACK);
2489 if (PL_expect == XREF)
2490 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2492 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2498 yylval.ival = PL_curcop->cop_line;
2499 if (isSPACE(*s) || *s == '#')
2500 PL_copline = NOLINE; /* invalidate current command line number */
2505 if (PL_lex_brackets <= 0)
2506 yyerror("Unmatched right bracket");
2508 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2509 if (PL_lex_brackets < PL_lex_formbrack)
2510 PL_lex_formbrack = 0;
2511 if (PL_lex_state == LEX_INTERPNORMAL) {
2512 if (PL_lex_brackets == 0) {
2513 if (PL_lex_fakebrack) {
2514 PL_lex_state = LEX_INTERPEND;
2516 return yylex(YYLEXPARAM); /* ignore fake brackets */
2518 if (*s == '-' && s[1] == '>')
2519 PL_lex_state = LEX_INTERPENDMAYBE;
2520 else if (*s != '[' && *s != '{')
2521 PL_lex_state = LEX_INTERPEND;
2524 if (PL_lex_brackets < PL_lex_fakebrack) {
2526 PL_lex_fakebrack = 0;
2527 return yylex(YYLEXPARAM); /* ignore fake brackets */
2537 if (PL_expect == XOPERATOR) {
2538 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2539 PL_curcop->cop_line--;
2540 warner(WARN_SEMICOLON, warn_nosemi);
2541 PL_curcop->cop_line++;
2546 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2548 PL_expect = XOPERATOR;
2549 force_ident(PL_tokenbuf, '&');
2553 yylval.ival = (OPpENTERSUB_AMPER<<8);
2572 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2573 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2575 if (PL_expect == XSTATE && isALPHA(tmp) &&
2576 (s == PL_linestart+1 || s[-2] == '\n') )
2578 if (PL_in_eval && !PL_rsfp) {
2583 if (strnEQ(s,"=cut",4)) {
2597 PL_doextract = TRUE;
2600 if (PL_lex_brackets < PL_lex_formbrack) {
2602 #ifdef PERL_STRICT_CR
2603 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2605 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2607 if (*t == '\n' || *t == '#') {
2625 if (PL_expect != XOPERATOR) {
2626 if (s[1] != '<' && !strchr(s,'>'))
2629 s = scan_heredoc(s);
2631 s = scan_inputsymbol(s);
2632 TERM(sublex_start());
2637 SHop(OP_LEFT_SHIFT);
2651 SHop(OP_RIGHT_SHIFT);
2660 if (PL_expect == XOPERATOR) {
2661 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2664 return ','; /* grandfather non-comma-format format */
2668 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2669 if (PL_expect == XOPERATOR)
2670 no_op("Array length", PL_bufptr);
2671 PL_tokenbuf[0] = '@';
2672 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2674 if (!PL_tokenbuf[1])
2676 PL_expect = XOPERATOR;
2677 PL_pending_ident = '#';
2681 if (PL_expect == XOPERATOR)
2682 no_op("Scalar", PL_bufptr);
2683 PL_tokenbuf[0] = '$';
2684 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2685 if (!PL_tokenbuf[1]) {
2687 yyerror("Final $ should be \\$ or $name");
2691 /* This kludge not intended to be bulletproof. */
2692 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2693 yylval.opval = newSVOP(OP_CONST, 0,
2694 newSViv((IV)PL_compiling.cop_arybase));
2695 yylval.opval->op_private = OPpCONST_ARYBASE;
2700 if (PL_lex_state == LEX_NORMAL)
2703 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2706 PL_tokenbuf[0] = '@';
2707 if (ckWARN(WARN_SYNTAX)) {
2709 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2712 PL_bufptr = skipspace(PL_bufptr);
2713 while (t < PL_bufend && *t != ']')
2716 "Multidimensional syntax %.*s not supported",
2717 (t - PL_bufptr) + 1, PL_bufptr);
2721 else if (*s == '{') {
2722 PL_tokenbuf[0] = '%';
2723 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2724 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2726 char tmpbuf[sizeof PL_tokenbuf];
2728 for (t++; isSPACE(*t); t++) ;
2729 if (isIDFIRST_lazy(t)) {
2730 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2731 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2733 "You need to quote \"%s\"", tmpbuf);
2739 PL_expect = XOPERATOR;
2740 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2741 bool islop = (PL_last_lop == PL_oldoldbufptr);
2742 if (!islop || PL_last_lop_op == OP_GREPSTART)
2743 PL_expect = XOPERATOR;
2744 else if (strchr("$@\"'`q", *s))
2745 PL_expect = XTERM; /* e.g. print $fh "foo" */
2746 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2747 PL_expect = XTERM; /* e.g. print $fh &sub */
2748 else if (isIDFIRST_lazy(s)) {
2749 char tmpbuf[sizeof PL_tokenbuf];
2750 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2751 if (tmp = keyword(tmpbuf, len)) {
2752 /* binary operators exclude handle interpretations */
2764 PL_expect = XTERM; /* e.g. print $fh length() */
2769 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2770 if (gv && GvCVu(gv))
2771 PL_expect = XTERM; /* e.g. print $fh subr() */
2774 else if (isDIGIT(*s))
2775 PL_expect = XTERM; /* e.g. print $fh 3 */
2776 else if (*s == '.' && isDIGIT(s[1]))
2777 PL_expect = XTERM; /* e.g. print $fh .3 */
2778 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2779 PL_expect = XTERM; /* e.g. print $fh -1 */
2780 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2781 PL_expect = XTERM; /* print $fh <<"EOF" */
2783 PL_pending_ident = '$';
2787 if (PL_expect == XOPERATOR)
2789 PL_tokenbuf[0] = '@';
2790 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2791 if (!PL_tokenbuf[1]) {
2793 yyerror("Final @ should be \\@ or @name");
2796 if (PL_lex_state == LEX_NORMAL)
2798 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2800 PL_tokenbuf[0] = '%';
2802 /* Warn about @ where they meant $. */
2803 if (ckWARN(WARN_SYNTAX)) {
2804 if (*s == '[' || *s == '{') {
2806 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2808 if (*t == '}' || *t == ']') {
2810 PL_bufptr = skipspace(PL_bufptr);
2812 "Scalar value %.*s better written as $%.*s",
2813 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2818 PL_pending_ident = '@';
2821 case '/': /* may either be division or pattern */
2822 case '?': /* may either be conditional or pattern */
2823 if (PL_expect != XOPERATOR) {
2824 /* Disable warning on "study /blah/" */
2825 if (PL_oldoldbufptr == PL_last_uni
2826 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2827 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2829 s = scan_pat(s,OP_MATCH);
2830 TERM(sublex_start());
2838 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2839 #ifdef PERL_STRICT_CR
2842 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2844 && (s == PL_linestart || s[-1] == '\n') )
2846 PL_lex_formbrack = 0;
2850 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2856 yylval.ival = OPf_SPECIAL;
2862 if (PL_expect != XOPERATOR)
2867 case '0': case '1': case '2': case '3': case '4':
2868 case '5': case '6': case '7': case '8': case '9':
2870 if (PL_expect == XOPERATOR)
2876 if (PL_expect == XOPERATOR) {
2877 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2880 return ','; /* grandfather non-comma-format format */
2886 missingterm((char*)0);
2887 yylval.ival = OP_CONST;
2888 TERM(sublex_start());
2892 if (PL_expect == XOPERATOR) {
2893 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2896 return ','; /* grandfather non-comma-format format */
2902 missingterm((char*)0);
2903 yylval.ival = OP_CONST;
2904 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2905 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2906 yylval.ival = OP_STRINGIFY;
2910 TERM(sublex_start());
2914 if (PL_expect == XOPERATOR)
2915 no_op("Backticks",s);
2917 missingterm((char*)0);
2918 yylval.ival = OP_BACKTICK;
2920 TERM(sublex_start());
2924 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2925 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2927 if (PL_expect == XOPERATOR)
2928 no_op("Backslash",s);
2932 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2971 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2973 /* Some keywords can be followed by any delimiter, including ':' */
2974 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2975 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2976 (PL_tokenbuf[0] == 'q' &&
2977 strchr("qwxr", PL_tokenbuf[1]))));
2979 /* x::* is just a word, unless x is "CORE" */
2980 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2984 while (d < PL_bufend && isSPACE(*d))
2985 d++; /* no comments skipped here, or s### is misparsed */
2987 /* Is this a label? */
2988 if (!tmp && PL_expect == XSTATE
2989 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2991 yylval.pval = savepv(PL_tokenbuf);
2996 /* Check for keywords */
2997 tmp = keyword(PL_tokenbuf, len);
2999 /* Is this a word before a => operator? */
3000 if (strnEQ(d,"=>",2)) {
3002 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3003 yylval.opval->op_private = OPpCONST_BARE;
3007 if (tmp < 0) { /* second-class keyword? */
3008 GV *ogv = Nullgv; /* override (winner) */
3009 GV *hgv = Nullgv; /* hidden (loser) */
3010 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3012 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3015 if (GvIMPORTED_CV(gv))
3017 else if (! CvMETHOD(cv))
3021 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3022 (gv = *gvp) != (GV*)&PL_sv_undef &&
3023 GvCVu(gv) && GvIMPORTED_CV(gv))
3029 tmp = 0; /* overridden by import or by GLOBAL */
3032 && -tmp==KEY_lock /* XXX generalizable kludge */
3033 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3035 tmp = 0; /* any sub overrides "weak" keyword */
3037 else { /* no override */
3041 if (ckWARN(WARN_AMBIGUOUS) && hgv
3042 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3043 warner(WARN_AMBIGUOUS,
3044 "Ambiguous call resolved as CORE::%s(), %s",
3045 GvENAME(hgv), "qualify as such or use &");
3052 default: /* not a keyword */
3055 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3057 /* Get the rest if it looks like a package qualifier */
3059 if (*s == '\'' || *s == ':' && s[1] == ':') {
3061 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3064 croak("Bad name after %s%s", PL_tokenbuf,
3065 *s == '\'' ? "'" : "::");
3069 if (PL_expect == XOPERATOR) {
3070 if (PL_bufptr == PL_linestart) {
3071 PL_curcop->cop_line--;
3072 warner(WARN_SEMICOLON, warn_nosemi);
3073 PL_curcop->cop_line++;
3076 no_op("Bareword",s);
3079 /* Look for a subroutine with this name in current package,
3080 unless name is "Foo::", in which case Foo is a bearword
3081 (and a package name). */
3084 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3086 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3088 "Bareword \"%s\" refers to nonexistent package",
3091 PL_tokenbuf[len] = '\0';
3098 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3101 /* if we saw a global override before, get the right name */
3104 sv = newSVpv("CORE::GLOBAL::",14);
3105 sv_catpv(sv,PL_tokenbuf);
3108 sv = newSVpv(PL_tokenbuf,0);
3110 /* Presume this is going to be a bareword of some sort. */
3113 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3114 yylval.opval->op_private = OPpCONST_BARE;
3116 /* And if "Foo::", then that's what it certainly is. */
3121 /* See if it's the indirect object for a list operator. */
3123 if (PL_oldoldbufptr &&
3124 PL_oldoldbufptr < PL_bufptr &&
3125 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3126 /* NO SKIPSPACE BEFORE HERE! */
3128 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3129 || (PL_last_lop_op == OP_ENTERSUB
3131 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3133 bool immediate_paren = *s == '(';
3135 /* (Now we can afford to cross potential line boundary.) */
3138 /* Two barewords in a row may indicate method call. */
3140 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3143 /* If not a declared subroutine, it's an indirect object. */
3144 /* (But it's an indir obj regardless for sort.) */
3146 if ((PL_last_lop_op == OP_SORT ||
3147 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3148 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3149 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3154 /* If followed by a paren, it's certainly a subroutine. */
3156 PL_expect = XOPERATOR;
3160 if (gv && GvCVu(gv)) {
3162 if ((cv = GvCV(gv)) && SvPOK(cv))
3163 PL_last_proto = SvPV((SV*)cv, PL_na);
3164 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3165 if (*d == ')' && (sv = cv_const_sv(cv))) {
3170 PL_nextval[PL_nexttoke].opval = yylval.opval;
3171 PL_expect = XOPERATOR;
3174 PL_last_lop_op = OP_ENTERSUB;
3178 /* If followed by var or block, call it a method (unless sub) */
3180 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3181 PL_last_lop = PL_oldbufptr;
3182 PL_last_lop_op = OP_METHOD;
3186 /* If followed by a bareword, see if it looks like indir obj. */
3188 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3191 /* Not a method, so call it a subroutine (if defined) */
3193 if (gv && GvCVu(gv)) {
3195 if (lastchar == '-')
3196 warn("Ambiguous use of -%s resolved as -&%s()",
3197 PL_tokenbuf, PL_tokenbuf);
3198 PL_last_lop = PL_oldbufptr;
3199 PL_last_lop_op = OP_ENTERSUB;
3200 /* Check for a constant sub */
3202 if ((sv = cv_const_sv(cv))) {
3204 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3205 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3206 yylval.opval->op_private = 0;
3210 /* Resolve to GV now. */
3211 op_free(yylval.opval);
3212 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3213 PL_last_lop_op = OP_ENTERSUB;
3214 /* Is there a prototype? */
3217 PL_last_proto = SvPV((SV*)cv, len);
3220 if (strEQ(PL_last_proto, "$"))
3222 if (*PL_last_proto == '&' && *s == '{') {
3223 sv_setpv(PL_subname,"__ANON__");
3227 PL_last_proto = NULL;
3228 PL_nextval[PL_nexttoke].opval = yylval.opval;
3234 if (PL_hints & HINT_STRICT_SUBS &&
3237 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3238 PL_last_lop_op != OP_ACCEPT &&
3239 PL_last_lop_op != OP_PIPE_OP &&
3240 PL_last_lop_op != OP_SOCKPAIR &&
3241 !(PL_last_lop_op == OP_ENTERSUB
3243 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3246 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3251 /* Call it a bare word */
3254 if (ckWARN(WARN_RESERVED)) {
3255 if (lastchar != '-') {
3256 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3258 warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
3263 if (lastchar && strchr("*%&", lastchar)) {
3264 warn("Operator or semicolon missing before %c%s",
3265 lastchar, PL_tokenbuf);
3266 warn("Ambiguous use of %c resolved as operator %c",
3267 lastchar, lastchar);
3273 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3274 newSVsv(GvSV(PL_curcop->cop_filegv)));
3278 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3279 newSVpvf("%ld", (long)PL_curcop->cop_line));
3282 case KEY___PACKAGE__:
3283 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3285 ? newSVsv(PL_curstname)
3294 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3295 char *pname = "main";
3296 if (PL_tokenbuf[2] == 'D')
3297 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3298 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3301 GvIOp(gv) = newIO();
3302 IoIFP(GvIOp(gv)) = PL_rsfp;
3303 #if defined(HAS_FCNTL) && defined(F_SETFD)
3305 int fd = PerlIO_fileno(PL_rsfp);
3306 fcntl(fd,F_SETFD,fd >= 3);
3309 /* Mark this internal pseudo-handle as clean */
3310 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3312 IoTYPE(GvIOp(gv)) = '|';
3313 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3314 IoTYPE(GvIOp(gv)) = '-';
3316 IoTYPE(GvIOp(gv)) = '<';
3327 if (PL_expect == XSTATE) {
3334 if (*s == ':' && s[1] == ':') {
3337 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3338 tmp = keyword(PL_tokenbuf, len);
3352 LOP(OP_ACCEPT,XTERM);
3358 LOP(OP_ATAN2,XTERM);
3367 LOP(OP_BLESS,XTERM);
3376 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3393 if (!PL_cryptseen++)
3396 LOP(OP_CRYPT,XTERM);
3399 if (ckWARN(WARN_OCTAL)) {
3400 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3401 if (*d != '0' && isDIGIT(*d))
3402 yywarn("chmod: mode argument is missing initial 0");
3404 LOP(OP_CHMOD,XTERM);
3407 LOP(OP_CHOWN,XTERM);
3410 LOP(OP_CONNECT,XTERM);
3426 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3430 PL_hints |= HINT_BLOCK_SCOPE;
3440 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3441 LOP(OP_DBMOPEN,XTERM);
3447 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3454 yylval.ival = PL_curcop->cop_line;
3468 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3469 UNIBRACK(OP_ENTEREVAL);
3484 case KEY_endhostent:
3490 case KEY_endservent:
3493 case KEY_endprotoent:
3504 yylval.ival = PL_curcop->cop_line;
3506 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3508 if ((PL_bufend - p) >= 3 &&
3509 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3512 if (isIDFIRST_lazy(p))
3513 croak("Missing $ on loop variable");
3518 LOP(OP_FORMLINE,XTERM);
3524 LOP(OP_FCNTL,XTERM);
3530 LOP(OP_FLOCK,XTERM);
3539 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3542 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3557 case KEY_getpriority:
3558 LOP(OP_GETPRIORITY,XTERM);
3560 case KEY_getprotobyname:
3563 case KEY_getprotobynumber:
3564 LOP(OP_GPBYNUMBER,XTERM);
3566 case KEY_getprotoent:
3578 case KEY_getpeername:
3579 UNI(OP_GETPEERNAME);
3581 case KEY_gethostbyname:
3584 case KEY_gethostbyaddr:
3585 LOP(OP_GHBYADDR,XTERM);
3587 case KEY_gethostent:
3590 case KEY_getnetbyname:
3593 case KEY_getnetbyaddr:
3594 LOP(OP_GNBYADDR,XTERM);
3599 case KEY_getservbyname:
3600 LOP(OP_GSBYNAME,XTERM);
3602 case KEY_getservbyport:
3603 LOP(OP_GSBYPORT,XTERM);
3605 case KEY_getservent:
3608 case KEY_getsockname:
3609 UNI(OP_GETSOCKNAME);
3611 case KEY_getsockopt:
3612 LOP(OP_GSOCKOPT,XTERM);
3634 yylval.ival = PL_curcop->cop_line;
3638 LOP(OP_INDEX,XTERM);
3644 LOP(OP_IOCTL,XTERM);
3656 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3687 LOP(OP_LISTEN,XTERM);
3696 s = scan_pat(s,OP_MATCH);
3697 TERM(sublex_start());
3700 LOP(OP_MAPSTART, XREF);
3703 LOP(OP_MKDIR,XTERM);
3706 LOP(OP_MSGCTL,XTERM);
3709 LOP(OP_MSGGET,XTERM);
3712 LOP(OP_MSGRCV,XTERM);
3715 LOP(OP_MSGSND,XTERM);
3720 if (isIDFIRST_lazy(s)) {
3721 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3722 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3723 if (!PL_in_my_stash) {
3726 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3733 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3740 if (PL_expect != XSTATE)
3741 yyerror("\"no\" not allowed in expression");
3742 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3743 s = force_version(s);
3752 if (isIDFIRST_lazy(s)) {
3754 for (d = s; isALNUM_lazy(d); d++) ;
3756 if (strchr("|&*+-=!?:.", *t))
3757 warn("Precedence problem: open %.*s should be open(%.*s)",
3763 yylval.ival = OP_OR;
3773 LOP(OP_OPEN_DIR,XTERM);
3776 checkcomma(s,PL_tokenbuf,"filehandle");
3780 checkcomma(s,PL_tokenbuf,"filehandle");
3799 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3803 LOP(OP_PIPE_OP,XTERM);
3808 missingterm((char*)0);
3809 yylval.ival = OP_CONST;
3810 TERM(sublex_start());
3818 missingterm((char*)0);
3819 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3820 d = SvPV_force(PL_lex_stuff, len);
3821 for (; len; --len, ++d) {
3824 "Possible attempt to separate words with commas");
3829 "Possible attempt to put comments in qw() list");
3835 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3836 PL_lex_stuff = Nullsv;
3839 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3842 yylval.ival = OP_SPLIT;
3846 PL_last_lop = PL_oldbufptr;
3847 PL_last_lop_op = OP_SPLIT;
3853 missingterm((char*)0);
3854 yylval.ival = OP_STRINGIFY;
3855 if (SvIVX(PL_lex_stuff) == '\'')
3856 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3857 TERM(sublex_start());
3860 s = scan_pat(s,OP_QR);
3861 TERM(sublex_start());
3866 missingterm((char*)0);
3867 yylval.ival = OP_BACKTICK;
3869 TERM(sublex_start());
3875 *PL_tokenbuf = '\0';
3876 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3877 if (isIDFIRST_lazy(PL_tokenbuf))
3878 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3880 yyerror("<> should be quotes");
3887 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3891 LOP(OP_RENAME,XTERM);
3900 LOP(OP_RINDEX,XTERM);
3923 LOP(OP_REVERSE,XTERM);
3934 TERM(sublex_start());
3936 TOKEN(1); /* force error */
3945 LOP(OP_SELECT,XTERM);
3951 LOP(OP_SEMCTL,XTERM);
3954 LOP(OP_SEMGET,XTERM);
3957 LOP(OP_SEMOP,XTERM);
3963 LOP(OP_SETPGRP,XTERM);
3965 case KEY_setpriority:
3966 LOP(OP_SETPRIORITY,XTERM);
3968 case KEY_sethostent:
3974 case KEY_setservent:
3977 case KEY_setprotoent:
3987 LOP(OP_SEEKDIR,XTERM);
3989 case KEY_setsockopt:
3990 LOP(OP_SSOCKOPT,XTERM);
3996 LOP(OP_SHMCTL,XTERM);
3999 LOP(OP_SHMGET,XTERM);
4002 LOP(OP_SHMREAD,XTERM);
4005 LOP(OP_SHMWRITE,XTERM);
4008 LOP(OP_SHUTDOWN,XTERM);
4017 LOP(OP_SOCKET,XTERM);
4019 case KEY_socketpair:
4020 LOP(OP_SOCKPAIR,XTERM);
4023 checkcomma(s,PL_tokenbuf,"subroutine name");
4025 if (*s == ';' || *s == ')') /* probably a close */
4026 croak("sort is now a reserved word");
4028 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4032 LOP(OP_SPLIT,XTERM);
4035 LOP(OP_SPRINTF,XTERM);
4038 LOP(OP_SPLICE,XTERM);
4054 LOP(OP_SUBSTR,XTERM);
4061 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4062 char tmpbuf[sizeof PL_tokenbuf];
4064 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4065 if (strchr(tmpbuf, ':'))
4066 sv_setpv(PL_subname, tmpbuf);
4068 sv_setsv(PL_subname,PL_curstname);
4069 sv_catpvn(PL_subname,"::",2);
4070 sv_catpvn(PL_subname,tmpbuf,len);
4072 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4076 PL_expect = XTERMBLOCK;
4077 sv_setpv(PL_subname,"?");
4080 if (tmp == KEY_format) {
4083 PL_lex_formbrack = PL_lex_brackets + 1;
4087 /* Look for a prototype */
4094 SvREFCNT_dec(PL_lex_stuff);
4095 PL_lex_stuff = Nullsv;
4096 croak("Prototype not terminated");
4099 d = SvPVX(PL_lex_stuff);
4101 for (p = d; *p; ++p) {
4106 SvCUR(PL_lex_stuff) = tmp;
4109 PL_nextval[1] = PL_nextval[0];
4110 PL_nexttype[1] = PL_nexttype[0];
4111 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4112 PL_nexttype[0] = THING;
4113 if (PL_nexttoke == 1) {
4114 PL_lex_defer = PL_lex_state;
4115 PL_lex_expect = PL_expect;
4116 PL_lex_state = LEX_KNOWNEXT;
4118 PL_lex_stuff = Nullsv;
4121 if (*SvPV(PL_subname,PL_na) == '?') {
4122 sv_setpv(PL_subname,"__ANON__");
4129 LOP(OP_SYSTEM,XREF);
4132 LOP(OP_SYMLINK,XTERM);
4135 LOP(OP_SYSCALL,XTERM);
4138 LOP(OP_SYSOPEN,XTERM);
4141 LOP(OP_SYSSEEK,XTERM);
4144 LOP(OP_SYSREAD,XTERM);
4147 LOP(OP_SYSWRITE,XTERM);
4151 TERM(sublex_start());
4172 LOP(OP_TRUNCATE,XTERM);
4184 yylval.ival = PL_curcop->cop_line;
4188 yylval.ival = PL_curcop->cop_line;
4192 LOP(OP_UNLINK,XTERM);
4198 LOP(OP_UNPACK,XTERM);
4201 LOP(OP_UTIME,XTERM);
4204 if (ckWARN(WARN_OCTAL)) {
4205 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4206 if (*d != '0' && isDIGIT(*d))
4207 yywarn("umask: argument is missing initial 0");
4212 LOP(OP_UNSHIFT,XTERM);
4215 if (PL_expect != XSTATE)
4216 yyerror("\"use\" not allowed in expression");
4219 s = force_version(s);
4220 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4221 PL_nextval[PL_nexttoke].opval = Nullop;
4226 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4227 s = force_version(s);
4240 yylval.ival = PL_curcop->cop_line;
4244 PL_hints |= HINT_BLOCK_SCOPE;
4251 LOP(OP_WAITPID,XTERM);
4259 static char ctl_l[2];
4261 if (ctl_l[0] == '\0')
4262 ctl_l[0] = toCTRL('L');
4263 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4266 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4271 if (PL_expect == XOPERATOR)
4277 yylval.ival = OP_XOR;
4282 TERM(sublex_start());
4288 keyword(register char *d, I32 len)
4293 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4294 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4295 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4296 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4297 if (strEQ(d,"__END__")) return KEY___END__;
4301 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4306 if (strEQ(d,"and")) return -KEY_and;
4307 if (strEQ(d,"abs")) return -KEY_abs;
4310 if (strEQ(d,"alarm")) return -KEY_alarm;
4311 if (strEQ(d,"atan2")) return -KEY_atan2;
4314 if (strEQ(d,"accept")) return -KEY_accept;
4319 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4322 if (strEQ(d,"bless")) return -KEY_bless;
4323 if (strEQ(d,"bind")) return -KEY_bind;
4324 if (strEQ(d,"binmode")) return -KEY_binmode;
4327 if (strEQ(d,"CORE")) return -KEY_CORE;
4332 if (strEQ(d,"cmp")) return -KEY_cmp;
4333 if (strEQ(d,"chr")) return -KEY_chr;
4334 if (strEQ(d,"cos")) return -KEY_cos;
4337 if (strEQ(d,"chop")) return KEY_chop;
4340 if (strEQ(d,"close")) return -KEY_close;
4341 if (strEQ(d,"chdir")) return -KEY_chdir;
4342 if (strEQ(d,"chomp")) return KEY_chomp;
4343 if (strEQ(d,"chmod")) return -KEY_chmod;
4344 if (strEQ(d,"chown")) return -KEY_chown;
4345 if (strEQ(d,"crypt")) return -KEY_crypt;
4348 if (strEQ(d,"chroot")) return -KEY_chroot;
4349 if (strEQ(d,"caller")) return -KEY_caller;
4352 if (strEQ(d,"connect")) return -KEY_connect;
4355 if (strEQ(d,"closedir")) return -KEY_closedir;
4356 if (strEQ(d,"continue")) return -KEY_continue;
4361 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4366 if (strEQ(d,"do")) return KEY_do;
4369 if (strEQ(d,"die")) return -KEY_die;
4372 if (strEQ(d,"dump")) return -KEY_dump;
4375 if (strEQ(d,"delete")) return KEY_delete;
4378 if (strEQ(d,"defined")) return KEY_defined;
4379 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4382 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4387 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4388 if (strEQ(d,"END")) return KEY_END;
4393 if (strEQ(d,"eq")) return -KEY_eq;
4396 if (strEQ(d,"eof")) return -KEY_eof;
4397 if (strEQ(d,"exp")) return -KEY_exp;
4400 if (strEQ(d,"else")) return KEY_else;
4401 if (strEQ(d,"exit")) return -KEY_exit;
4402 if (strEQ(d,"eval")) return KEY_eval;
4403 if (strEQ(d,"exec")) return -KEY_exec;
4404 if (strEQ(d,"each")) return KEY_each;
4407 if (strEQ(d,"elsif")) return KEY_elsif;
4410 if (strEQ(d,"exists")) return KEY_exists;
4411 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4414 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4415 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4418 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4421 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4422 if (strEQ(d,"endservent")) return -KEY_endservent;
4425 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4432 if (strEQ(d,"for")) return KEY_for;
4435 if (strEQ(d,"fork")) return -KEY_fork;
4438 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4439 if (strEQ(d,"flock")) return -KEY_flock;
4442 if (strEQ(d,"format")) return KEY_format;
4443 if (strEQ(d,"fileno")) return -KEY_fileno;
4446 if (strEQ(d,"foreach")) return KEY_foreach;
4449 if (strEQ(d,"formline")) return -KEY_formline;
4455 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4456 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4460 if (strnEQ(d,"get",3)) {
4465 if (strEQ(d,"ppid")) return -KEY_getppid;
4466 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4469 if (strEQ(d,"pwent")) return -KEY_getpwent;
4470 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4471 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4474 if (strEQ(d,"peername")) return -KEY_getpeername;
4475 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4476 if (strEQ(d,"priority")) return -KEY_getpriority;
4479 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4482 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4486 else if (*d == 'h') {
4487 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4488 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4489 if (strEQ(d,"hostent")) return -KEY_gethostent;
4491 else if (*d == 'n') {
4492 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4493 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4494 if (strEQ(d,"netent")) return -KEY_getnetent;
4496 else if (*d == 's') {
4497 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4498 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4499 if (strEQ(d,"servent")) return -KEY_getservent;
4500 if (strEQ(d,"sockname")) return -KEY_getsockname;
4501 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4503 else if (*d == 'g') {
4504 if (strEQ(d,"grent")) return -KEY_getgrent;
4505 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4506 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4508 else if (*d == 'l') {
4509 if (strEQ(d,"login")) return -KEY_getlogin;
4511 else if (strEQ(d,"c")) return -KEY_getc;
4516 if (strEQ(d,"gt")) return -KEY_gt;
4517 if (strEQ(d,"ge")) return -KEY_ge;
4520 if (strEQ(d,"grep")) return KEY_grep;
4521 if (strEQ(d,"goto")) return KEY_goto;
4522 if (strEQ(d,"glob")) return KEY_glob;
4525 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4530 if (strEQ(d,"hex")) return -KEY_hex;
4533 if (strEQ(d,"INIT")) return KEY_INIT;
4538 if (strEQ(d,"if")) return KEY_if;
4541 if (strEQ(d,"int")) return -KEY_int;
4544 if (strEQ(d,"index")) return -KEY_index;
4545 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4550 if (strEQ(d,"join")) return -KEY_join;
4554 if (strEQ(d,"keys")) return KEY_keys;
4555 if (strEQ(d,"kill")) return -KEY_kill;
4560 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4561 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4567 if (strEQ(d,"lt")) return -KEY_lt;
4568 if (strEQ(d,"le")) return -KEY_le;
4569 if (strEQ(d,"lc")) return -KEY_lc;
4572 if (strEQ(d,"log")) return -KEY_log;
4575 if (strEQ(d,"last")) return KEY_last;
4576 if (strEQ(d,"link")) return -KEY_link;
4577 if (strEQ(d,"lock")) return -KEY_lock;
4580 if (strEQ(d,"local")) return KEY_local;
4581 if (strEQ(d,"lstat")) return -KEY_lstat;
4584 if (strEQ(d,"length")) return -KEY_length;
4585 if (strEQ(d,"listen")) return -KEY_listen;
4588 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4591 if (strEQ(d,"localtime")) return -KEY_localtime;
4597 case 1: return KEY_m;
4599 if (strEQ(d,"my")) return KEY_my;
4602 if (strEQ(d,"map")) return KEY_map;
4605 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4608 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4609 if (strEQ(d,"msgget")) return -KEY_msgget;
4610 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4611 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4616 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4619 if (strEQ(d,"next")) return KEY_next;
4620 if (strEQ(d,"ne")) return -KEY_ne;
4621 if (strEQ(d,"not")) return -KEY_not;
4622 if (strEQ(d,"no")) return KEY_no;
4627 if (strEQ(d,"or")) return -KEY_or;
4630 if (strEQ(d,"ord")) return -KEY_ord;
4631 if (strEQ(d,"oct")) return -KEY_oct;
4632 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4636 if (strEQ(d,"open")) return -KEY_open;
4639 if (strEQ(d,"opendir")) return -KEY_opendir;
4646 if (strEQ(d,"pop")) return KEY_pop;
4647 if (strEQ(d,"pos")) return KEY_pos;
4650 if (strEQ(d,"push")) return KEY_push;
4651 if (strEQ(d,"pack")) return -KEY_pack;
4652 if (strEQ(d,"pipe")) return -KEY_pipe;
4655 if (strEQ(d,"print")) return KEY_print;
4658 if (strEQ(d,"printf")) return KEY_printf;
4661 if (strEQ(d,"package")) return KEY_package;
4664 if (strEQ(d,"prototype")) return KEY_prototype;
4669 if (strEQ(d,"q")) return KEY_q;
4670 if (strEQ(d,"qr")) return KEY_qr;
4671 if (strEQ(d,"qq")) return KEY_qq;
4672 if (strEQ(d,"qw")) return KEY_qw;
4673 if (strEQ(d,"qx")) return KEY_qx;
4675 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4680 if (strEQ(d,"ref")) return -KEY_ref;
4683 if (strEQ(d,"read")) return -KEY_read;
4684 if (strEQ(d,"rand")) return -KEY_rand;
4685 if (strEQ(d,"recv")) return -KEY_recv;
4686 if (strEQ(d,"redo")) return KEY_redo;
4689 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4690 if (strEQ(d,"reset")) return -KEY_reset;
4693 if (strEQ(d,"return")) return KEY_return;
4694 if (strEQ(d,"rename")) return -KEY_rename;
4695 if (strEQ(d,"rindex")) return -KEY_rindex;
4698 if (strEQ(d,"require")) return -KEY_require;
4699 if (strEQ(d,"reverse")) return -KEY_reverse;
4700 if (strEQ(d,"readdir")) return -KEY_readdir;
4703 if (strEQ(d,"readlink")) return -KEY_readlink;
4704 if (strEQ(d,"readline")) return -KEY_readline;
4705 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4708 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4714 case 0: return KEY_s;
4716 if (strEQ(d,"scalar")) return KEY_scalar;
4721 if (strEQ(d,"seek")) return -KEY_seek;
4722 if (strEQ(d,"send")) return -KEY_send;
4725 if (strEQ(d,"semop")) return -KEY_semop;
4728 if (strEQ(d,"select")) return -KEY_select;
4729 if (strEQ(d,"semctl")) return -KEY_semctl;
4730 if (strEQ(d,"semget")) return -KEY_semget;
4733 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4734 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4737 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4738 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4741 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4744 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4745 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4746 if (strEQ(d,"setservent")) return -KEY_setservent;
4749 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4750 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4757 if (strEQ(d,"shift")) return KEY_shift;
4760 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4761 if (strEQ(d,"shmget")) return -KEY_shmget;
4764 if (strEQ(d,"shmread")) return -KEY_shmread;
4767 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4768 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4773 if (strEQ(d,"sin")) return -KEY_sin;
4776 if (strEQ(d,"sleep")) return -KEY_sleep;
4779 if (strEQ(d,"sort")) return KEY_sort;
4780 if (strEQ(d,"socket")) return -KEY_socket;
4781 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4784 if (strEQ(d,"split")) return KEY_split;
4785 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4786 if (strEQ(d,"splice")) return KEY_splice;
4789 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4792 if (strEQ(d,"srand")) return -KEY_srand;
4795 if (strEQ(d,"stat")) return -KEY_stat;
4796 if (strEQ(d,"study")) return KEY_study;
4799 if (strEQ(d,"substr")) return -KEY_substr;
4800 if (strEQ(d,"sub")) return KEY_sub;
4805 if (strEQ(d,"system")) return -KEY_system;
4808 if (strEQ(d,"symlink")) return -KEY_symlink;
4809 if (strEQ(d,"syscall")) return -KEY_syscall;
4810 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4811 if (strEQ(d,"sysread")) return -KEY_sysread;
4812 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4815 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4824 if (strEQ(d,"tr")) return KEY_tr;
4827 if (strEQ(d,"tie")) return KEY_tie;
4830 if (strEQ(d,"tell")) return -KEY_tell;
4831 if (strEQ(d,"tied")) return KEY_tied;
4832 if (strEQ(d,"time")) return -KEY_time;
4835 if (strEQ(d,"times")) return -KEY_times;
4838 if (strEQ(d,"telldir")) return -KEY_telldir;
4841 if (strEQ(d,"truncate")) return -KEY_truncate;
4848 if (strEQ(d,"uc")) return -KEY_uc;
4851 if (strEQ(d,"use")) return KEY_use;
4854 if (strEQ(d,"undef")) return KEY_undef;
4855 if (strEQ(d,"until")) return KEY_until;
4856 if (strEQ(d,"untie")) return KEY_untie;
4857 if (strEQ(d,"utime")) return -KEY_utime;
4858 if (strEQ(d,"umask")) return -KEY_umask;
4861 if (strEQ(d,"unless")) return KEY_unless;
4862 if (strEQ(d,"unpack")) return -KEY_unpack;
4863 if (strEQ(d,"unlink")) return -KEY_unlink;
4866 if (strEQ(d,"unshift")) return KEY_unshift;
4867 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4872 if (strEQ(d,"values")) return -KEY_values;
4873 if (strEQ(d,"vec")) return -KEY_vec;
4878 if (strEQ(d,"warn")) return -KEY_warn;
4879 if (strEQ(d,"wait")) return -KEY_wait;
4882 if (strEQ(d,"while")) return KEY_while;
4883 if (strEQ(d,"write")) return -KEY_write;
4886 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4889 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4894 if (len == 1) return -KEY_x;
4895 if (strEQ(d,"xor")) return -KEY_xor;
4898 if (len == 1) return KEY_y;
4907 checkcomma(register char *s, char *name, char *what)
4911 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4912 dTHR; /* only for ckWARN */
4913 if (ckWARN(WARN_SYNTAX)) {
4915 for (w = s+2; *w && level; w++) {
4922 for (; *w && isSPACE(*w); w++) ;
4923 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4924 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4927 while (s < PL_bufend && isSPACE(*s))
4931 while (s < PL_bufend && isSPACE(*s))
4933 if (isIDFIRST_lazy(s)) {
4935 while (isALNUM_lazy(s))
4937 while (s < PL_bufend && isSPACE(*s))
4942 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4946 croak("No comma allowed after %s", what);
4952 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4955 HV *table = GvHV(PL_hintgv); /* ^H */
4958 bool oldcatch = CATCH_GET;
4964 yyerror("%^H is not defined");
4967 cvp = hv_fetch(table, key, strlen(key), FALSE);
4968 if (!cvp || !SvOK(*cvp)) {
4969 sprintf(buf,"$^H{%s} is not defined", key);
4973 sv_2mortal(sv); /* Parent created it permanently */
4976 pv = sv_2mortal(newSVpv(s, len));
4978 typesv = sv_2mortal(newSVpv(type, 0));
4980 typesv = &PL_sv_undef;
4982 Zero(&myop, 1, BINOP);
4983 myop.op_last = (OP *) &myop;
4984 myop.op_next = Nullop;
4985 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4987 PUSHSTACKi(PERLSI_OVERLOAD);
4990 PL_op = (OP *) &myop;
4991 if (PERLDB_SUB && PL_curstash != PL_debstash)
4992 PL_op->op_private |= OPpENTERSUB_DB;
5003 if (PL_op = pp_entersub(ARGS))
5010 CATCH_SET(oldcatch);
5014 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5017 return SvREFCNT_inc(res);
5021 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5023 register char *d = dest;
5024 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5027 croak(ident_too_long);
5028 if (isALNUM(*s)) /* UTF handled below */
5030 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5035 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5039 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5040 char *t = s + UTF8SKIP(s);
5041 while (*t & 0x80 && is_utf8_mark((U8*)t))
5043 if (d + (t - s) > e)
5044 croak(ident_too_long);
5045 Copy(s, d, t - s, char);
5058 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5065 if (PL_lex_brackets == 0)
5066 PL_lex_fakebrack = 0;
5070 e = d + destlen - 3; /* two-character token, ending NUL */
5072 while (isDIGIT(*s)) {
5074 croak(ident_too_long);
5081 croak(ident_too_long);
5082 if (isALNUM(*s)) /* UTF handled below */
5084 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5089 else if (*s == ':' && s[1] == ':') {
5093 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5094 char *t = s + UTF8SKIP(s);
5095 while (*t & 0x80 && is_utf8_mark((U8*)t))
5097 if (d + (t - s) > e)
5098 croak(ident_too_long);
5099 Copy(s, d, t - s, char);
5110 if (PL_lex_state != LEX_NORMAL)
5111 PL_lex_state = LEX_INTERPENDMAYBE;
5114 if (*s == '$' && s[1] &&
5115 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5128 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5133 if (isSPACE(s[-1])) {
5136 if (ch != ' ' && ch != '\t') {
5142 if (isIDFIRST_lazy(d)) {
5146 while (e < send && isALNUM_lazy(e) || *e == ':') {
5148 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5151 Copy(s, d, e - s, char);
5156 while (isALNUM(*s) || *s == ':')
5160 while (s < send && (*s == ' ' || *s == '\t')) s++;
5161 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5162 dTHR; /* only for ckWARN */
5163 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5164 char *brack = *s == '[' ? "[...]" : "{...}";
5165 warner(WARN_AMBIGUOUS,
5166 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5167 funny, dest, brack, funny, dest, brack);
5169 PL_lex_fakebrack = PL_lex_brackets+1;
5171 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5177 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5178 PL_lex_state = LEX_INTERPEND;
5181 if (PL_lex_state == LEX_NORMAL) {
5182 dTHR; /* only for ckWARN */
5183 if (ckWARN(WARN_AMBIGUOUS) &&
5184 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5186 warner(WARN_AMBIGUOUS,
5187 "Ambiguous use of %c{%s} resolved to %c%s",
5188 funny, dest, funny, dest);
5193 s = bracket; /* let the parser handle it */
5197 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5198 PL_lex_state = LEX_INTERPEND;
5202 void pmflag(U16 *pmfl, int ch)
5207 *pmfl |= PMf_GLOBAL;
5209 *pmfl |= PMf_CONTINUE;
5213 *pmfl |= PMf_MULTILINE;
5215 *pmfl |= PMf_SINGLELINE;
5217 *pmfl |= PMf_EXTENDED;
5221 scan_pat(char *start, I32 type)
5226 s = scan_str(start);
5229 SvREFCNT_dec(PL_lex_stuff);
5230 PL_lex_stuff = Nullsv;
5231 croak("Search pattern not terminated");
5234 pm = (PMOP*)newPMOP(type, 0);
5235 if (PL_multi_open == '?')
5236 pm->op_pmflags |= PMf_ONCE;
5238 while (*s && strchr("iomsx", *s))
5239 pmflag(&pm->op_pmflags,*s++);
5242 while (*s && strchr("iogcmsx", *s))
5243 pmflag(&pm->op_pmflags,*s++);
5245 pm->op_pmpermflags = pm->op_pmflags;
5247 PL_lex_op = (OP*)pm;
5248 yylval.ival = OP_MATCH;
5253 scan_subst(char *start)
5260 yylval.ival = OP_NULL;
5262 s = scan_str(start);
5266 SvREFCNT_dec(PL_lex_stuff);
5267 PL_lex_stuff = Nullsv;
5268 croak("Substitution pattern not terminated");
5271 if (s[-1] == PL_multi_open)
5274 first_start = PL_multi_start;
5278 SvREFCNT_dec(PL_lex_stuff);
5279 PL_lex_stuff = Nullsv;
5281 SvREFCNT_dec(PL_lex_repl);
5282 PL_lex_repl = Nullsv;
5283 croak("Substitution replacement not terminated");
5285 PL_multi_start = first_start; /* so whole substitution is taken together */
5287 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5293 else if (strchr("iogcmsx", *s))
5294 pmflag(&pm->op_pmflags,*s++);
5301 pm->op_pmflags |= PMf_EVAL;
5302 repl = newSVpv("",0);
5304 sv_catpv(repl, es ? "eval " : "do ");
5305 sv_catpvn(repl, "{ ", 2);
5306 sv_catsv(repl, PL_lex_repl);
5307 sv_catpvn(repl, " };", 2);
5308 SvCOMPILED_on(repl);
5309 SvREFCNT_dec(PL_lex_repl);
5313 pm->op_pmpermflags = pm->op_pmflags;
5314 PL_lex_op = (OP*)pm;
5315 yylval.ival = OP_SUBST;
5320 scan_trans(char *start)
5331 yylval.ival = OP_NULL;
5333 s = scan_str(start);
5336 SvREFCNT_dec(PL_lex_stuff);
5337 PL_lex_stuff = Nullsv;
5338 croak("Transliteration pattern not terminated");
5340 if (s[-1] == PL_multi_open)
5346 SvREFCNT_dec(PL_lex_stuff);
5347 PL_lex_stuff = Nullsv;
5349 SvREFCNT_dec(PL_lex_repl);
5350 PL_lex_repl = Nullsv;
5351 croak("Transliteration replacement not terminated");
5355 o = newSVOP(OP_TRANS, 0, 0);
5356 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5359 New(803,tbl,256,short);
5360 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5364 complement = del = squash = 0;
5365 while (strchr("cdsCU", *s)) {
5367 complement = OPpTRANS_COMPLEMENT;
5369 del = OPpTRANS_DELETE;
5371 squash = OPpTRANS_SQUASH;
5376 utf8 &= ~OPpTRANS_FROM_UTF;
5378 utf8 |= OPpTRANS_FROM_UTF;
5382 utf8 &= ~OPpTRANS_TO_UTF;
5384 utf8 |= OPpTRANS_TO_UTF;
5387 croak("Too many /C and /U options");
5392 o->op_private = del|squash|complement|utf8;
5395 yylval.ival = OP_TRANS;
5400 scan_heredoc(register char *s)
5404 I32 op_type = OP_SCALAR;
5411 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5415 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5418 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5419 if (*peek && strchr("`'\"",*peek)) {
5422 s = delimcpy(d, e, s, PL_bufend, term, &len);
5432 if (!isALNUM_lazy(s))
5433 deprecate("bare << to mean <<\"\"");
5434 for (; isALNUM_lazy(s); s++) {
5439 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5440 croak("Delimiter for here document is too long");
5443 len = d - PL_tokenbuf;
5444 #ifndef PERL_STRICT_CR
5445 d = strchr(s, '\r');
5449 while (s < PL_bufend) {
5455 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5464 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5469 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5470 herewas = newSVpv(s,PL_bufend-s);
5472 s--, herewas = newSVpv(s,d-s);
5473 s += SvCUR(herewas);
5475 tmpstr = NEWSV(87,79);
5476 sv_upgrade(tmpstr, SVt_PVIV);
5481 else if (term == '`') {
5482 op_type = OP_BACKTICK;
5483 SvIVX(tmpstr) = '\\';
5487 PL_multi_start = PL_curcop->cop_line;
5488 PL_multi_open = PL_multi_close = '<';
5489 term = *PL_tokenbuf;
5492 while (s < PL_bufend &&
5493 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5495 PL_curcop->cop_line++;
5497 if (s >= PL_bufend) {
5498 PL_curcop->cop_line = PL_multi_start;
5499 missingterm(PL_tokenbuf);
5501 sv_setpvn(tmpstr,d+1,s-d);
5503 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5505 sv_catpvn(herewas,s,PL_bufend-s);
5506 sv_setsv(PL_linestr,herewas);
5507 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5508 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5511 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5512 while (s >= PL_bufend) { /* multiple line string? */
5514 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5515 PL_curcop->cop_line = PL_multi_start;
5516 missingterm(PL_tokenbuf);
5518 PL_curcop->cop_line++;
5519 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5520 #ifndef PERL_STRICT_CR
5521 if (PL_bufend - PL_linestart >= 2) {
5522 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5523 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5525 PL_bufend[-2] = '\n';
5527 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5529 else if (PL_bufend[-1] == '\r')
5530 PL_bufend[-1] = '\n';
5532 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5533 PL_bufend[-1] = '\n';
5535 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5536 SV *sv = NEWSV(88,0);
5538 sv_upgrade(sv, SVt_PVMG);
5539 sv_setsv(sv,PL_linestr);
5540 av_store(GvAV(PL_curcop->cop_filegv),
5541 (I32)PL_curcop->cop_line,sv);
5543 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5546 sv_catsv(PL_linestr,herewas);
5547 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5551 sv_catsv(tmpstr,PL_linestr);
5554 PL_multi_end = PL_curcop->cop_line;
5556 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5557 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5558 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5560 SvREFCNT_dec(herewas);
5561 PL_lex_stuff = tmpstr;
5562 yylval.ival = op_type;
5567 takes: current position in input buffer
5568 returns: new position in input buffer
5569 side-effects: yylval and lex_op are set.
5574 <FH> read from filehandle
5575 <pkg::FH> read from package qualified filehandle
5576 <pkg'FH> read from package qualified filehandle
5577 <$fh> read from filehandle in $fh
5583 scan_inputsymbol(char *start)
5585 register char *s = start; /* current position in buffer */
5590 d = PL_tokenbuf; /* start of temp holding space */
5591 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5592 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5594 /* die if we didn't have space for the contents of the <>,
5598 if (len >= sizeof PL_tokenbuf)
5599 croak("Excessively long <> operator");
5601 croak("Unterminated <> operator");
5606 Remember, only scalar variables are interpreted as filehandles by
5607 this code. Anything more complex (e.g., <$fh{$num}>) will be
5608 treated as a glob() call.
5609 This code makes use of the fact that except for the $ at the front,
5610 a scalar variable and a filehandle look the same.
5612 if (*d == '$' && d[1]) d++;
5614 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5615 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5618 /* If we've tried to read what we allow filehandles to look like, and
5619 there's still text left, then it must be a glob() and not a getline.
5620 Use scan_str to pull out the stuff between the <> and treat it
5621 as nothing more than a string.
5624 if (d - PL_tokenbuf != len) {
5625 yylval.ival = OP_GLOB;
5627 s = scan_str(start);
5629 croak("Glob not terminated");
5633 /* we're in a filehandle read situation */
5636 /* turn <> into <ARGV> */
5638 (void)strcpy(d,"ARGV");
5640 /* if <$fh>, create the ops to turn the variable into a
5646 /* try to find it in the pad for this block, otherwise find
5647 add symbol table ops
5649 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5650 OP *o = newOP(OP_PADSV, 0);
5652 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5655 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5656 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5657 newUNOP(OP_RV2GV, 0,
5658 newUNOP(OP_RV2SV, 0,
5659 newGVOP(OP_GV, 0, gv))));
5661 /* we created the ops in lex_op, so make yylval.ival a null op */
5662 yylval.ival = OP_NULL;
5665 /* If it's none of the above, it must be a literal filehandle
5666 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5668 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5669 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5670 yylval.ival = OP_NULL;
5679 takes: start position in buffer
5680 returns: position to continue reading from buffer
5681 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5682 updates the read buffer.
5684 This subroutine pulls a string out of the input. It is called for:
5685 q single quotes q(literal text)
5686 ' single quotes 'literal text'
5687 qq double quotes qq(interpolate $here please)
5688 " double quotes "interpolate $here please"
5689 qx backticks qx(/bin/ls -l)
5690 ` backticks `/bin/ls -l`
5691 qw quote words @EXPORT_OK = qw( func() $spam )
5692 m// regexp match m/this/
5693 s/// regexp substitute s/this/that/
5694 tr/// string transliterate tr/this/that/
5695 y/// string transliterate y/this/that/
5696 ($*@) sub prototypes sub foo ($)
5697 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5699 In most of these cases (all but <>, patterns and transliterate)
5700 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5701 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5702 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5705 It skips whitespace before the string starts, and treats the first
5706 character as the delimiter. If the delimiter is one of ([{< then
5707 the corresponding "close" character )]}> is used as the closing
5708 delimiter. It allows quoting of delimiters, and if the string has
5709 balanced delimiters ([{<>}]) it allows nesting.
5711 The lexer always reads these strings into lex_stuff, except in the
5712 case of the operators which take *two* arguments (s/// and tr///)
5713 when it checks to see if lex_stuff is full (presumably with the 1st
5714 arg to s or tr) and if so puts the string into lex_repl.
5719 scan_str(char *start)
5722 SV *sv; /* scalar value: string */
5723 char *tmps; /* temp string, used for delimiter matching */
5724 register char *s = start; /* current position in the buffer */
5725 register char term; /* terminating character */
5726 register char *to; /* current position in the sv's data */
5727 I32 brackets = 1; /* bracket nesting level */
5729 /* skip space before the delimiter */
5733 /* mark where we are, in case we need to report errors */
5736 /* after skipping whitespace, the next character is the terminator */
5738 /* mark where we are */
5739 PL_multi_start = PL_curcop->cop_line;
5740 PL_multi_open = term;
5742 /* find corresponding closing delimiter */
5743 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5745 PL_multi_close = term;
5747 /* create a new SV to hold the contents. 87 is leak category, I'm
5748 assuming. 79 is the SV's initial length. What a random number. */
5750 sv_upgrade(sv, SVt_PVIV);
5752 (void)SvPOK_only(sv); /* validate pointer */
5754 /* move past delimiter and try to read a complete string */
5757 /* extend sv if need be */
5758 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5759 /* set 'to' to the next character in the sv's string */
5760 to = SvPVX(sv)+SvCUR(sv);
5762 /* if open delimiter is the close delimiter read unbridle */
5763 if (PL_multi_open == PL_multi_close) {
5764 for (; s < PL_bufend; s++,to++) {
5765 /* embedded newlines increment the current line number */
5766 if (*s == '\n' && !PL_rsfp)
5767 PL_curcop->cop_line++;
5768 /* handle quoted delimiters */
5769 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5772 /* any other quotes are simply copied straight through */
5776 /* terminate when run out of buffer (the for() condition), or
5777 have found the terminator */
5778 else if (*s == term)
5784 /* if the terminator isn't the same as the start character (e.g.,
5785 matched brackets), we have to allow more in the quoting, and
5786 be prepared for nested brackets.
5789 /* read until we run out of string, or we find the terminator */
5790 for (; s < PL_bufend; s++,to++) {
5791 /* embedded newlines increment the line count */
5792 if (*s == '\n' && !PL_rsfp)
5793 PL_curcop->cop_line++;
5794 /* backslashes can escape the open or closing characters */
5795 if (*s == '\\' && s+1 < PL_bufend) {
5796 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5801 /* allow nested opens and closes */
5802 else if (*s == PL_multi_close && --brackets <= 0)
5804 else if (*s == PL_multi_open)
5809 /* terminate the copied string and update the sv's end-of-string */
5811 SvCUR_set(sv, to - SvPVX(sv));
5814 * this next chunk reads more into the buffer if we're not done yet
5817 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5819 #ifndef PERL_STRICT_CR
5820 if (to - SvPVX(sv) >= 2) {
5821 if ((to[-2] == '\r' && to[-1] == '\n') ||
5822 (to[-2] == '\n' && to[-1] == '\r'))
5826 SvCUR_set(sv, to - SvPVX(sv));
5828 else if (to[-1] == '\r')
5831 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5835 /* if we're out of file, or a read fails, bail and reset the current
5836 line marker so we can report where the unterminated string began
5839 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5841 PL_curcop->cop_line = PL_multi_start;
5844 /* we read a line, so increment our line counter */
5845 PL_curcop->cop_line++;
5847 /* update debugger info */
5848 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5849 SV *sv = NEWSV(88,0);
5851 sv_upgrade(sv, SVt_PVMG);
5852 sv_setsv(sv,PL_linestr);
5853 av_store(GvAV(PL_curcop->cop_filegv),
5854 (I32)PL_curcop->cop_line, sv);
5857 /* having changed the buffer, we must update PL_bufend */
5858 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5861 /* at this point, we have successfully read the delimited string */
5863 PL_multi_end = PL_curcop->cop_line;
5866 /* if we allocated too much space, give some back */
5867 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5868 SvLEN_set(sv, SvCUR(sv) + 1);
5869 Renew(SvPVX(sv), SvLEN(sv), char);
5872 /* decide whether this is the first or second quoted string we've read
5885 takes: pointer to position in buffer
5886 returns: pointer to new position in buffer
5887 side-effects: builds ops for the constant in yylval.op
5889 Read a number in any of the formats that Perl accepts:
5891 0(x[0-7A-F]+)|([0-7]+)
5892 [\d_]+(\.[\d_]*)?[Ee](\d+)
5894 Underbars (_) are allowed in decimal numbers. If -w is on,
5895 underbars before a decimal point must be at three digit intervals.
5897 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5900 If it reads a number without a decimal point or an exponent, it will
5901 try converting the number to an integer and see if it can do so
5902 without loss of precision.
5906 scan_num(char *start)
5908 register char *s = start; /* current position in buffer */
5909 register char *d; /* destination in temp buffer */
5910 register char *e; /* end of temp buffer */
5911 I32 tryiv; /* used to see if it can be an int */
5912 double value; /* number read, as a double */
5913 SV *sv; /* place to put the converted number */
5914 I32 floatit; /* boolean: int or float? */
5915 char *lastub = 0; /* position of last underbar */
5916 static char number_too_long[] = "Number too long";
5918 /* We use the first character to decide what type of number this is */
5922 croak("panic: scan_num");
5924 /* if it starts with a 0, it could be an octal number, a decimal in
5925 0.13 disguise, or a hexadecimal number.
5930 u holds the "number so far"
5931 shift the power of 2 of the base (hex == 4, octal == 3)
5932 overflowed was the number more than we can hold?
5934 Shift is used when we add a digit. It also serves as an "are
5935 we in octal or hex?" indicator to disallow hex characters when
5940 bool overflowed = FALSE;
5947 /* check for a decimal in disguise */
5948 else if (s[1] == '.')
5950 /* so it must be octal */
5955 /* read the rest of the octal number */
5957 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5961 /* if we don't mention it, we're done */
5970 /* 8 and 9 are not octal */
5973 yyerror("Illegal octal digit");
5977 case '0': case '1': case '2': case '3': case '4':
5978 case '5': case '6': case '7':
5979 b = *s++ & 15; /* ASCII digit -> value of digit */
5983 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5984 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5985 /* make sure they said 0x */
5990 /* Prepare to put the digit we have onto the end
5991 of the number so far. We check for overflows.
5995 n = u << shift; /* make room for the digit */
5996 if (!overflowed && (n >> shift) != u
5997 && !(PL_hints & HINT_NEW_BINARY)) {
5998 warn("Integer overflow in %s number",
5999 (shift == 4) ? "hex" : "octal");
6002 u = n | b; /* add the digit to the end */
6007 /* if we get here, we had success: make a scalar value from
6013 if ( PL_hints & HINT_NEW_BINARY)
6014 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6019 handle decimal numbers.
6020 we're also sent here when we read a 0 as the first digit
6022 case '1': case '2': case '3': case '4': case '5':
6023 case '6': case '7': case '8': case '9': case '.':
6026 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6029 /* read next group of digits and _ and copy into d */
6030 while (isDIGIT(*s) || *s == '_') {
6031 /* skip underscores, checking for misplaced ones
6035 dTHR; /* only for ckWARN */
6036 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6037 warner(WARN_SYNTAX, "Misplaced _ in number");
6041 /* check for end of fixed-length buffer */
6043 croak(number_too_long);
6044 /* if we're ok, copy the character */
6049 /* final misplaced underbar check */
6050 if (lastub && s - lastub != 3) {
6052 if (ckWARN(WARN_SYNTAX))
6053 warner(WARN_SYNTAX, "Misplaced _ in number");
6056 /* read a decimal portion if there is one. avoid
6057 3..5 being interpreted as the number 3. followed
6060 if (*s == '.' && s[1] != '.') {
6064 /* copy, ignoring underbars, until we run out of
6065 digits. Note: no misplaced underbar checks!
6067 for (; isDIGIT(*s) || *s == '_'; s++) {
6068 /* fixed length buffer check */
6070 croak(number_too_long);
6076 /* read exponent part, if present */
6077 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6081 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6082 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6084 /* allow positive or negative exponent */
6085 if (*s == '+' || *s == '-')
6088 /* read digits of exponent (no underbars :-) */
6089 while (isDIGIT(*s)) {
6091 croak(number_too_long);
6096 /* terminate the string */
6099 /* make an sv from the string */
6101 /* reset numeric locale in case we were earlier left in Swaziland */
6102 SET_NUMERIC_STANDARD();
6103 value = atof(PL_tokenbuf);
6106 See if we can make do with an integer value without loss of
6107 precision. We use I_V to cast to an int, because some
6108 compilers have issues. Then we try casting it back and see
6109 if it was the same. We only do this if we know we
6110 specifically read an integer.
6112 Note: if floatit is true, then we don't need to do the
6116 if (!floatit && (double)tryiv == value)
6117 sv_setiv(sv, tryiv);
6119 sv_setnv(sv, value);
6120 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6121 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6122 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6126 /* make the op for the constant and return */
6128 yylval.opval = newSVOP(OP_CONST, 0, sv);
6134 scan_formline(register char *s)
6139 SV *stuff = newSVpv("",0);
6140 bool needargs = FALSE;
6143 if (*s == '.' || *s == '}') {
6145 #ifdef PERL_STRICT_CR
6146 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6148 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6153 if (PL_in_eval && !PL_rsfp) {
6154 eol = strchr(s,'\n');
6159 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6161 for (t = s; t < eol; t++) {
6162 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6164 goto enough; /* ~~ must be first line in formline */
6166 if (*t == '@' || *t == '^')
6169 sv_catpvn(stuff, s, eol-s);
6173 s = filter_gets(PL_linestr, PL_rsfp, 0);
6174 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6175 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6178 yyerror("Format not terminated");
6188 PL_lex_state = LEX_NORMAL;
6189 PL_nextval[PL_nexttoke].ival = 0;
6193 PL_lex_state = LEX_FORMLINE;
6194 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6196 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6200 SvREFCNT_dec(stuff);
6201 PL_lex_formbrack = 0;
6212 PL_cshlen = strlen(PL_cshname);
6217 start_subparse(I32 is_format, U32 flags)
6220 I32 oldsavestack_ix = PL_savestack_ix;
6221 CV* outsidecv = PL_compcv;
6225 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6227 save_I32(&PL_subline);
6228 save_item(PL_subname);
6230 SAVESPTR(PL_curpad);
6231 SAVESPTR(PL_comppad);
6232 SAVESPTR(PL_comppad_name);
6233 SAVESPTR(PL_compcv);
6234 SAVEI32(PL_comppad_name_fill);
6235 SAVEI32(PL_min_intro_pending);
6236 SAVEI32(PL_max_intro_pending);
6237 SAVEI32(PL_pad_reset_pending);
6239 PL_compcv = (CV*)NEWSV(1104,0);
6240 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6241 CvFLAGS(PL_compcv) |= flags;
6243 PL_comppad = newAV();
6244 av_push(PL_comppad, Nullsv);
6245 PL_curpad = AvARRAY(PL_comppad);
6246 PL_comppad_name = newAV();
6247 PL_comppad_name_fill = 0;
6248 PL_min_intro_pending = 0;
6250 PL_subline = PL_curcop->cop_line;
6252 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6253 PL_curpad[0] = (SV*)newAV();
6254 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6255 #endif /* USE_THREADS */
6257 comppadlist = newAV();
6258 AvREAL_off(comppadlist);
6259 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6260 av_store(comppadlist, 1, (SV*)PL_comppad);
6262 CvPADLIST(PL_compcv) = comppadlist;
6263 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6265 CvOWNER(PL_compcv) = 0;
6266 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6267 MUTEX_INIT(CvMUTEXP(PL_compcv));
6268 #endif /* USE_THREADS */
6270 return oldsavestack_ix;
6289 char *context = NULL;
6293 if (!yychar || (yychar == ';' && !PL_rsfp))
6295 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6296 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6297 while (isSPACE(*PL_oldoldbufptr))
6299 context = PL_oldoldbufptr;
6300 contlen = PL_bufptr - PL_oldoldbufptr;
6302 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6303 PL_oldbufptr != PL_bufptr) {
6304 while (isSPACE(*PL_oldbufptr))
6306 context = PL_oldbufptr;
6307 contlen = PL_bufptr - PL_oldbufptr;
6309 else if (yychar > 255)
6310 where = "next token ???";
6311 else if ((yychar & 127) == 127) {
6312 if (PL_lex_state == LEX_NORMAL ||
6313 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6314 where = "at end of line";
6315 else if (PL_lex_inpat)
6316 where = "within pattern";
6318 where = "within string";
6321 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6323 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6324 else if (isPRINT_LC(yychar))
6325 sv_catpvf(where_sv, "%c", yychar);
6327 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6328 where = SvPVX(where_sv);
6330 msg = sv_2mortal(newSVpv(s, 0));
6331 sv_catpvf(msg, " at %_ line %ld, ",
6332 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6334 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6336 sv_catpvf(msg, "%s\n", where);
6337 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6339 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6340 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6345 else if (PL_in_eval)
6346 sv_catsv(ERRSV, msg);
6348 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6349 if (++PL_error_count >= 10)
6350 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6352 PL_in_my_stash = Nullhv;