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)
123 #include "keywords.h"
128 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
130 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
131 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
132 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
133 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
134 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
135 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
136 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
137 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
138 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
139 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
140 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
141 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
142 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
143 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
144 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
145 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
146 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
147 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
148 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
149 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
151 /* This bit of chicanery makes a unary function followed by
152 * a parenthesis into a function with one argument, highest precedence.
154 #define UNI(f) return(yylval.ival = f, \
157 PL_last_uni = PL_oldbufptr, \
158 PL_last_lop_op = f, \
159 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
161 #define UNIBRACK(f) return(yylval.ival = f, \
163 PL_last_uni = PL_oldbufptr, \
164 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
166 /* grandfather return to old style */
167 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
172 if (*PL_bufptr == '=') {
174 if (toketype == ANDAND)
175 yylval.ival = OP_ANDASSIGN;
176 else if (toketype == OROR)
177 yylval.ival = OP_ORASSIGN;
184 no_op(char *what, char *s)
186 char *oldbp = PL_bufptr;
187 bool is_first = (PL_oldbufptr == PL_linestart);
190 yywarn(form("%s found where operator expected", what));
192 warn("\t(Missing semicolon on previous line?)\n");
193 else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
195 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
196 if (t < PL_bufptr && isSPACE(*t))
197 warn("\t(Do you need to predeclare %.*s?)\n",
198 t - PL_oldoldbufptr, PL_oldoldbufptr);
202 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
212 char *nl = strrchr(s,'\n');
218 iscntrl(PL_multi_close)
220 PL_multi_close < 32 || PL_multi_close == 127
224 tmpbuf[1] = toCTRL(PL_multi_close);
230 *tmpbuf = PL_multi_close;
234 q = strchr(s,'"') ? '\'' : '"';
235 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
242 if (ckWARN(WARN_DEPRECATED))
243 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
249 deprecate("comma-less variable list");
255 win32_textfilter(int idx, SV *sv, int maxlen)
257 I32 count = FILTER_READ(idx+1, sv, maxlen);
258 if (count > 0 && !maxlen)
259 win32_strip_return(sv);
267 utf16_textfilter(int idx, SV *sv, int maxlen)
269 I32 count = FILTER_READ(idx+1, sv, maxlen);
273 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
274 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
275 sv_usepvn(sv, (char*)tmps, tend - tmps);
282 utf16rev_textfilter(int idx, SV *sv, int maxlen)
284 I32 count = FILTER_READ(idx+1, sv, maxlen);
288 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
289 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
290 sv_usepvn(sv, (char*)tmps, tend - tmps);
305 SAVEI32(PL_lex_dojoin);
306 SAVEI32(PL_lex_brackets);
307 SAVEI32(PL_lex_fakebrack);
308 SAVEI32(PL_lex_casemods);
309 SAVEI32(PL_lex_starts);
310 SAVEI32(PL_lex_state);
311 SAVESPTR(PL_lex_inpat);
312 SAVEI32(PL_lex_inwhat);
313 SAVEI16(PL_curcop->cop_line);
316 SAVEPPTR(PL_oldbufptr);
317 SAVEPPTR(PL_oldoldbufptr);
318 SAVEPPTR(PL_linestart);
319 SAVESPTR(PL_linestr);
320 SAVEPPTR(PL_lex_brackstack);
321 SAVEPPTR(PL_lex_casestack);
322 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
323 SAVESPTR(PL_lex_stuff);
324 SAVEI32(PL_lex_defer);
325 SAVESPTR(PL_lex_repl);
326 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
327 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
329 PL_lex_state = LEX_NORMAL;
333 PL_lex_fakebrack = 0;
334 New(899, PL_lex_brackstack, 120, char);
335 New(899, PL_lex_casestack, 12, char);
336 SAVEFREEPV(PL_lex_brackstack);
337 SAVEFREEPV(PL_lex_casestack);
339 *PL_lex_casestack = '\0';
342 PL_lex_stuff = Nullsv;
343 PL_lex_repl = Nullsv;
347 if (SvREADONLY(PL_linestr))
348 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
349 s = SvPV(PL_linestr, len);
350 if (len && s[len-1] != ';') {
351 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
352 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
353 sv_catpvn(PL_linestr, "\n;", 2);
355 SvTEMP_off(PL_linestr);
356 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
357 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
359 PL_rs = newSVpv("\n", 1);
366 PL_doextract = FALSE;
370 restore_rsfp(void *f)
372 PerlIO *fp = (PerlIO*)f;
374 if (PL_rsfp == PerlIO_stdin())
375 PerlIO_clearerr(PL_rsfp);
376 else if (PL_rsfp && (PL_rsfp != fp))
377 PerlIO_close(PL_rsfp);
382 restore_expect(void *e)
384 /* a safe way to store a small integer in a pointer */
385 PL_expect = (expectation)((char *)e - PL_tokenbuf);
389 restore_lex_expect(void *e)
391 /* a safe way to store a small integer in a pointer */
392 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
404 PL_curcop->cop_line++;
407 while (*s == ' ' || *s == '\t') s++;
408 if (strnEQ(s, "line ", 5)) {
417 while (*s == ' ' || *s == '\t')
419 if (*s == '"' && (t = strchr(s+1, '"')))
423 return; /* false alarm */
424 for (t = s; !isSPACE(*t); t++) ;
429 PL_curcop->cop_filegv = gv_fetchfile(s);
431 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
433 PL_curcop->cop_line = atoi(n)-1;
437 skipspace(register char *s)
440 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
441 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
447 while (s < PL_bufend && isSPACE(*s))
449 if (s < PL_bufend && *s == '#') {
450 while (s < PL_bufend && *s != '\n')
455 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
457 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
458 if (PL_minus_n || PL_minus_p) {
459 sv_setpv(PL_linestr,PL_minus_p ?
460 ";}continue{print or die qq(-p destination: $!\\n)" :
462 sv_catpv(PL_linestr,";}");
463 PL_minus_n = PL_minus_p = 0;
466 sv_setpv(PL_linestr,";");
467 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
468 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
469 if (PL_preprocess && !PL_in_eval)
470 (void)PerlProc_pclose(PL_rsfp);
471 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
472 PerlIO_clearerr(PL_rsfp);
474 (void)PerlIO_close(PL_rsfp);
478 PL_linestart = PL_bufptr = s + prevlen;
479 PL_bufend = s + SvCUR(PL_linestr);
482 if (PERLDB_LINE && PL_curstash != PL_debstash) {
483 SV *sv = NEWSV(85,0);
485 sv_upgrade(sv, SVt_PVMG);
486 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
487 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
498 if (PL_oldoldbufptr != PL_last_uni)
500 while (isSPACE(*PL_last_uni))
502 for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
503 if ((t = strchr(s, '(')) && t < PL_bufptr)
507 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
514 #define UNI(f) return uni(f,s)
522 PL_last_uni = PL_oldbufptr;
533 #endif /* CRIPPLED_CC */
535 #define LOP(f,x) return lop(f,x,s)
538 lop(I32 f, expectation x, char *s)
545 PL_last_lop = PL_oldbufptr;
561 PL_nexttype[PL_nexttoke] = type;
563 if (PL_lex_state != LEX_KNOWNEXT) {
564 PL_lex_defer = PL_lex_state;
565 PL_lex_expect = PL_expect;
566 PL_lex_state = LEX_KNOWNEXT;
571 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
576 start = skipspace(start);
578 if (isIDFIRST_lazy(s) ||
579 (allow_pack && *s == ':') ||
580 (allow_initial_tick && *s == '\'') )
582 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
583 if (check_keyword && keyword(PL_tokenbuf, len))
585 if (token == METHOD) {
590 PL_expect = XOPERATOR;
595 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
596 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
603 force_ident(register char *s, int kind)
606 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
607 PL_nextval[PL_nexttoke].opval = o;
610 dTHR; /* just for in_eval */
611 o->op_private = OPpCONST_ENTERED;
612 /* XXX see note in pp_entereval() for why we forgo typo
613 warnings if the symbol must be introduced in an eval.
615 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
616 kind == '$' ? SVt_PV :
617 kind == '@' ? SVt_PVAV :
618 kind == '%' ? SVt_PVHV :
626 force_version(char *s)
628 OP *version = Nullop;
632 /* default VERSION number -- GBARR */
637 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
638 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
640 /* real VERSION number -- GBARR */
641 version = yylval.opval;
645 /* NOTE: The parser sees the package name and the VERSION swapped */
646 PL_nextval[PL_nexttoke].opval = version;
664 s = SvPV_force(sv, len);
668 while (s < send && *s != '\\')
673 if ( PL_hints & HINT_NEW_STRING )
674 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
677 if (s + 1 < send && (s[1] == '\\'))
678 s++; /* all that, just for this */
683 SvCUR_set(sv, d - SvPVX(sv));
685 if ( PL_hints & HINT_NEW_STRING )
686 return new_constant(NULL, 0, "q", sv, pv, "q");
693 register I32 op_type = yylval.ival;
695 if (op_type == OP_NULL) {
696 yylval.opval = PL_lex_op;
700 if (op_type == OP_CONST || op_type == OP_READLINE) {
701 SV *sv = tokeq(PL_lex_stuff);
703 if (SvTYPE(sv) == SVt_PVIV) {
704 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
710 nsv = newSVpv(p, len);
714 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
715 PL_lex_stuff = Nullsv;
719 PL_sublex_info.super_state = PL_lex_state;
720 PL_sublex_info.sub_inwhat = op_type;
721 PL_sublex_info.sub_op = PL_lex_op;
722 PL_lex_state = LEX_INTERPPUSH;
726 yylval.opval = PL_lex_op;
740 PL_lex_state = PL_sublex_info.super_state;
741 SAVEI32(PL_lex_dojoin);
742 SAVEI32(PL_lex_brackets);
743 SAVEI32(PL_lex_fakebrack);
744 SAVEI32(PL_lex_casemods);
745 SAVEI32(PL_lex_starts);
746 SAVEI32(PL_lex_state);
747 SAVESPTR(PL_lex_inpat);
748 SAVEI32(PL_lex_inwhat);
749 SAVEI16(PL_curcop->cop_line);
751 SAVEPPTR(PL_oldbufptr);
752 SAVEPPTR(PL_oldoldbufptr);
753 SAVEPPTR(PL_linestart);
754 SAVESPTR(PL_linestr);
755 SAVEPPTR(PL_lex_brackstack);
756 SAVEPPTR(PL_lex_casestack);
758 PL_linestr = PL_lex_stuff;
759 PL_lex_stuff = Nullsv;
761 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
762 PL_bufend += SvCUR(PL_linestr);
763 SAVEFREESV(PL_linestr);
765 PL_lex_dojoin = FALSE;
767 PL_lex_fakebrack = 0;
768 New(899, PL_lex_brackstack, 120, char);
769 New(899, PL_lex_casestack, 12, char);
770 SAVEFREEPV(PL_lex_brackstack);
771 SAVEFREEPV(PL_lex_casestack);
773 *PL_lex_casestack = '\0';
775 PL_lex_state = LEX_INTERPCONCAT;
776 PL_curcop->cop_line = PL_multi_start;
778 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
779 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
780 PL_lex_inpat = PL_sublex_info.sub_op;
782 PL_lex_inpat = Nullop;
790 if (!PL_lex_starts++) {
791 PL_expect = XOPERATOR;
792 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
796 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
797 PL_lex_state = LEX_INTERPCASEMOD;
798 return yylex(PERL_YYLEX_PARAM_DECL);
801 /* Is there a right-hand side to take care of? */
802 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
803 PL_linestr = PL_lex_repl;
805 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
806 PL_bufend += SvCUR(PL_linestr);
807 SAVEFREESV(PL_linestr);
808 PL_lex_dojoin = FALSE;
810 PL_lex_fakebrack = 0;
812 *PL_lex_casestack = '\0';
814 if (SvCOMPILED(PL_lex_repl)) {
815 PL_lex_state = LEX_INTERPNORMAL;
819 PL_lex_state = LEX_INTERPCONCAT;
820 PL_lex_repl = Nullsv;
825 PL_bufend = SvPVX(PL_linestr);
826 PL_bufend += SvCUR(PL_linestr);
827 PL_expect = XOPERATOR;
835 Extracts a pattern, double-quoted string, or transliteration. This
838 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
839 processing a pattern (PL_lex_inpat is true), a transliteration
840 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
842 Returns a pointer to the character scanned up to. Iff this is
843 advanced from the start pointer supplied (ie if anything was
844 successfully parsed), will leave an OP for the substring scanned
845 in yylval. Caller must intuit reason for not parsing further
846 by looking at the next characters herself.
850 double-quoted style: \r and \n
851 regexp special ones: \D \s
853 backrefs: \1 (deprecated in substitution replacements)
854 case and quoting: \U \Q \E
855 stops on @ and $, but not for $ as tail anchor
858 characters are VERY literal, except for - not at the start or end
859 of the string, which indicates a range. scan_const expands the
860 range to the full set of intermediate characters.
862 In double-quoted strings:
864 double-quoted style: \r and \n
866 backrefs: \1 (deprecated)
867 case and quoting: \U \Q \E
870 scan_const does *not* construct ops to handle interpolated strings.
871 It stops processing as soon as it finds an embedded $ or @ variable
872 and leaves it to the caller to work out what's going on.
874 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
876 $ in pattern could be $foo or could be tail anchor. Assumption:
877 it's a tail anchor if $ is the last thing in the string, or if it's
878 followed by one of ")| \n\t"
880 \1 (backreferences) are turned into $1
882 The structure of the code is
883 while (there's a character to process) {
884 handle transliteration ranges
886 skip # initiated comments in //x patterns
887 check for embedded @foo
888 check for embedded scalars
890 leave intact backslashes from leave (below)
891 deprecate \1 in strings and sub replacements
892 handle string-changing backslashes \l \U \Q \E, etc.
893 switch (what was escaped) {
894 handle - in a transliteration (becomes a literal -)
895 handle \132 octal characters
896 handle 0x15 hex characters
897 handle \cV (control V)
898 handle printf backslashes (\f, \r, \n, etc)
901 } (end while character to read)
906 scan_const(char *start)
908 register char *send = PL_bufend; /* end of the constant */
909 SV *sv = NEWSV(93, send - start); /* sv for the constant */
910 register char *s = start; /* start of the constant */
911 register char *d = SvPVX(sv); /* destination for copies */
912 bool dorange = FALSE; /* are we in a translit range? */
914 I32 utf = PL_lex_inwhat == OP_TRANS
915 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
917 I32 thisutf = PL_lex_inwhat == OP_TRANS
918 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
921 /* leaveit is the set of acceptably-backslashed characters */
924 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
927 while (s < send || dorange) {
928 /* get transliterations out of the way (they're most literal) */
929 if (PL_lex_inwhat == OP_TRANS) {
930 /* expand a range A-Z to the full set of characters. AIE! */
932 I32 i; /* current expanded character */
933 I32 min; /* first character in range */
934 I32 max; /* last character in range */
936 i = d - SvPVX(sv); /* remember current offset */
937 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
938 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
939 d -= 2; /* eat the first char and the - */
941 min = (U8)*d; /* first char in range */
942 max = (U8)d[1]; /* last char in range */
945 if ((isLOWER(min) && isLOWER(max)) ||
946 (isUPPER(min) && isUPPER(max))) {
948 for (i = min; i <= max; i++)
952 for (i = min; i <= max; i++)
959 for (i = min; i <= max; i++)
962 /* mark the range as done, and continue */
967 /* range begins (ignore - as first or last char) */
968 else if (*s == '-' && s+1 < send && s != start) {
970 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
979 /* if we get here, we're not doing a transliteration */
981 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
982 except for the last char, which will be done separately. */
983 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
985 while (s < send && *s != ')')
987 } else if (s[2] == '{'
988 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
990 char *regparse = s + (s[2] == '{' ? 3 : 4);
993 while (count && (c = *regparse)) {
994 if (c == '\\' && regparse[1])
1002 if (*regparse != ')') {
1003 regparse--; /* Leave one char for continuation. */
1004 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1006 while (s < regparse)
1011 /* likewise skip #-initiated comments in //x patterns */
1012 else if (*s == '#' && PL_lex_inpat &&
1013 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1014 while (s+1 < send && *s != '\n')
1018 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1019 else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1022 /* check for embedded scalars. only stop if we're sure it's a
1025 else if (*s == '$') {
1026 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1028 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1029 break; /* in regexp, $ might be tail anchor */
1032 /* (now in tr/// code again) */
1034 if (*s & 0x80 && thisutf) {
1035 dTHR; /* only for ckWARN */
1036 if (ckWARN(WARN_UTF8)) {
1037 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1047 if (*s == '\\' && s+1 < send) {
1050 /* some backslashes we leave behind */
1051 if (*s && strchr(leaveit, *s)) {
1057 /* deprecate \1 in strings and substitution replacements */
1058 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1059 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1061 dTHR; /* only for ckWARN */
1062 if (ckWARN(WARN_SYNTAX))
1063 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1068 /* string-change backslash escapes */
1069 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1074 /* if we get here, it's either a quoted -, or a digit */
1077 /* quoted - in transliterations */
1079 if (PL_lex_inwhat == OP_TRANS) {
1084 /* default action is to copy the quoted character */
1089 /* \132 indicates an octal constant */
1090 case '0': case '1': case '2': case '3':
1091 case '4': case '5': case '6': case '7':
1092 *d++ = scan_oct(s, 3, &len);
1096 /* \x24 indicates a hex constant */
1100 char* e = strchr(s, '}');
1103 yyerror("Missing right brace on \\x{}");
1108 if (ckWARN(WARN_UTF8))
1110 "Use of \\x{} without utf8 declaration");
1112 /* note: utf always shorter than hex */
1113 d = (char*)uv_to_utf8((U8*)d,
1114 scan_hex(s + 1, e - s - 1, &len));
1119 UV uv = (UV)scan_hex(s, 2, &len);
1120 if (utf && PL_lex_inwhat == OP_TRANS &&
1121 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1123 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1126 if (uv >= 127 && UTF) {
1128 if (ckWARN(WARN_UTF8))
1130 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1139 /* \c is a control character */
1153 /* printf-style backslashes, formfeeds, newlines, etc */
1179 } /* end if (backslash) */
1182 } /* while loop to process each character */
1184 /* terminate the string and set up the sv */
1186 SvCUR_set(sv, d - SvPVX(sv));
1189 /* shrink the sv if we allocated more than we used */
1190 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1191 SvLEN_set(sv, SvCUR(sv) + 1);
1192 Renew(SvPVX(sv), SvLEN(sv), char);
1195 /* return the substring (via yylval) only if we parsed anything */
1196 if (s > PL_bufptr) {
1197 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1198 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1200 ( PL_lex_inwhat == OP_TRANS
1202 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1205 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1211 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1213 intuit_more(register char *s)
1215 if (PL_lex_brackets)
1217 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1219 if (*s != '{' && *s != '[')
1224 /* In a pattern, so maybe we have {n,m}. */
1241 /* On the other hand, maybe we have a character class */
1244 if (*s == ']' || *s == '^')
1247 int weight = 2; /* let's weigh the evidence */
1249 unsigned char un_char = 255, last_un_char;
1250 char *send = strchr(s,']');
1251 char tmpbuf[sizeof PL_tokenbuf * 4];
1253 if (!send) /* has to be an expression */
1256 Zero(seen,256,char);
1259 else if (isDIGIT(*s)) {
1261 if (isDIGIT(s[1]) && s[2] == ']')
1267 for (; s < send; s++) {
1268 last_un_char = un_char;
1269 un_char = (unsigned char)*s;
1274 weight -= seen[un_char] * 10;
1275 if (isALNUM_lazy(s+1)) {
1276 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1277 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1282 else if (*s == '$' && s[1] &&
1283 strchr("[#!%*<>()-=",s[1])) {
1284 if (/*{*/ strchr("])} =",s[2]))
1293 if (strchr("wds]",s[1]))
1295 else if (seen['\''] || seen['"'])
1297 else if (strchr("rnftbxcav",s[1]))
1299 else if (isDIGIT(s[1])) {
1301 while (s[1] && isDIGIT(s[1]))
1311 if (strchr("aA01! ",last_un_char))
1313 if (strchr("zZ79~",s[1]))
1315 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1316 weight -= 5; /* cope with negative subscript */
1319 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1320 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1325 if (keyword(tmpbuf, d - tmpbuf))
1328 if (un_char == last_un_char + 1)
1330 weight -= seen[un_char];
1335 if (weight >= 0) /* probably a character class */
1343 intuit_method(char *start, GV *gv)
1345 char *s = start + (*start == '$');
1346 char tmpbuf[sizeof PL_tokenbuf];
1354 if ((cv = GvCVu(gv))) {
1355 char *proto = SvPVX(cv);
1365 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1366 if (*start == '$') {
1367 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1372 return *s == '(' ? FUNCMETH : METHOD;
1374 if (!keyword(tmpbuf, len)) {
1375 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1380 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1381 if (indirgv && GvCVu(indirgv))
1383 /* filehandle or package name makes it a method */
1384 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1386 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1387 return 0; /* no assumptions -- "=>" quotes bearword */
1389 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1391 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1395 return *s == '(' ? FUNCMETH : METHOD;
1405 char *pdb = PerlEnv_getenv("PERL5DB");
1409 SETERRNO(0,SS$_NORMAL);
1410 return "BEGIN { require 'perl5db.pl' }";
1416 /* Encoded script support. filter_add() effectively inserts a
1417 * 'pre-processing' function into the current source input stream.
1418 * Note that the filter function only applies to the current source file
1419 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1421 * The datasv parameter (which may be NULL) can be used to pass
1422 * private data to this instance of the filter. The filter function
1423 * can recover the SV using the FILTER_DATA macro and use it to
1424 * store private buffers and state information.
1426 * The supplied datasv parameter is upgraded to a PVIO type
1427 * and the IoDIRP field is used to store the function pointer.
1428 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1429 * private use must be set using malloc'd pointers.
1431 static int filter_debug = 0;
1434 filter_add(filter_t funcp, SV *datasv)
1436 if (!funcp){ /* temporary handy debugging hack to be deleted */
1437 filter_debug = atoi((char*)datasv);
1440 if (!PL_rsfp_filters)
1441 PL_rsfp_filters = newAV();
1443 datasv = NEWSV(255,0);
1444 if (!SvUPGRADE(datasv, SVt_PVIO))
1445 die("Can't upgrade filter_add data to SVt_PVIO");
1446 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1448 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1449 av_unshift(PL_rsfp_filters, 1);
1450 av_store(PL_rsfp_filters, 0, datasv) ;
1455 /* Delete most recently added instance of this filter function. */
1457 filter_del(filter_t funcp)
1460 warn("filter_del func %p", funcp);
1461 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1463 /* if filter is on top of stack (usual case) just pop it off */
1464 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1465 sv_free(av_pop(PL_rsfp_filters));
1469 /* we need to search for the correct entry and clear it */
1470 die("filter_del can only delete in reverse order (currently)");
1474 /* Invoke the n'th filter function for the current rsfp. */
1476 filter_read(int idx, SV *buf_sv, int maxlen)
1479 /* 0 = read one text line */
1484 if (!PL_rsfp_filters)
1486 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1487 /* Provide a default input filter to make life easy. */
1488 /* Note that we append to the line. This is handy. */
1490 warn("filter_read %d: from rsfp\n", idx);
1494 int old_len = SvCUR(buf_sv) ;
1496 /* ensure buf_sv is large enough */
1497 SvGROW(buf_sv, old_len + maxlen) ;
1498 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1499 if (PerlIO_error(PL_rsfp))
1500 return -1; /* error */
1502 return 0 ; /* end of file */
1504 SvCUR_set(buf_sv, old_len + len) ;
1507 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1508 if (PerlIO_error(PL_rsfp))
1509 return -1; /* error */
1511 return 0 ; /* end of file */
1514 return SvCUR(buf_sv);
1516 /* Skip this filter slot if filter has been deleted */
1517 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1519 warn("filter_read %d: skipped (filter deleted)\n", idx);
1520 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1522 /* Get function pointer hidden within datasv */
1523 funcp = (filter_t)IoDIRP(datasv);
1525 warn("filter_read %d: via function %p (%s)\n",
1526 idx, funcp, SvPV(datasv,PL_na));
1527 /* Call function. The function is expected to */
1528 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1529 /* Return: <0:error, =0:eof, >0:not eof */
1530 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1534 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1537 if (!PL_rsfp_filters) {
1538 filter_add(win32_textfilter,NULL);
1541 if (PL_rsfp_filters) {
1544 SvCUR_set(sv, 0); /* start with empty line */
1545 if (FILTER_READ(0, sv, 0) > 0)
1546 return ( SvPVX(sv) ) ;
1551 return (sv_gets(sv, fp, append));
1556 static char* exp_name[] =
1557 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1563 Works out what to call the token just pulled out of the input
1564 stream. The yacc parser takes care of taking the ops we return and
1565 stitching them into a tree.
1571 if read an identifier
1572 if we're in a my declaration
1573 croak if they tried to say my($foo::bar)
1574 build the ops for a my() declaration
1575 if it's an access to a my() variable
1576 are we in a sort block?
1577 croak if my($a); $a <=> $b
1578 build ops for access to a my() variable
1579 if in a dq string, and they've said @foo and we can't find @foo
1581 build ops for a bareword
1582 if we already built the token before, use it.
1585 int yylex(PERL_YYLEX_PARAM_DECL)
1595 #ifdef USE_PURE_BISON
1596 yylval_pointer = lvalp;
1597 yychar_pointer = lcharp;
1600 /* check if there's an identifier for us to look at */
1601 if (PL_pending_ident) {
1602 /* pit holds the identifier we read and pending_ident is reset */
1603 char pit = PL_pending_ident;
1604 PL_pending_ident = 0;
1606 /* if we're in a my(), we can't allow dynamics here.
1607 $foo'bar has already been turned into $foo::bar, so
1608 just check for colons.
1610 if it's a legal name, the OP is a PADANY.
1613 if (strchr(PL_tokenbuf,':'))
1614 croak(no_myglob,PL_tokenbuf);
1616 yylval.opval = newOP(OP_PADANY, 0);
1617 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1622 build the ops for accesses to a my() variable.
1624 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1625 then used in a comparison. This catches most, but not
1626 all cases. For instance, it catches
1627 sort { my($a); $a <=> $b }
1629 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1630 (although why you'd do that is anyone's guess).
1633 if (!strchr(PL_tokenbuf,':')) {
1635 /* Check for single character per-thread SVs */
1636 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1637 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1638 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1640 yylval.opval = newOP(OP_THREADSV, 0);
1641 yylval.opval->op_targ = tmp;
1644 #endif /* USE_THREADS */
1645 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1646 /* if it's a sort block and they're naming $a or $b */
1647 if (PL_last_lop_op == OP_SORT &&
1648 PL_tokenbuf[0] == '$' &&
1649 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1652 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1653 d < PL_bufend && *d != '\n';
1656 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1657 croak("Can't use \"my %s\" in sort comparison",
1663 yylval.opval = newOP(OP_PADANY, 0);
1664 yylval.opval->op_targ = tmp;
1670 Whine if they've said @foo in a doublequoted string,
1671 and @foo isn't a variable we can find in the symbol
1674 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1675 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1676 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1677 yyerror(form("In string, %s now must be written as \\%s",
1678 PL_tokenbuf, PL_tokenbuf));
1681 /* build ops for a bareword */
1682 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1683 yylval.opval->op_private = OPpCONST_ENTERED;
1684 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1685 ((PL_tokenbuf[0] == '$') ? SVt_PV
1686 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1691 /* no identifier pending identification */
1693 switch (PL_lex_state) {
1695 case LEX_NORMAL: /* Some compilers will produce faster */
1696 case LEX_INTERPNORMAL: /* code if we comment these out. */
1700 /* when we're already built the next token, just pull it out the queue */
1703 yylval = PL_nextval[PL_nexttoke];
1705 PL_lex_state = PL_lex_defer;
1706 PL_expect = PL_lex_expect;
1707 PL_lex_defer = LEX_NORMAL;
1709 return(PL_nexttype[PL_nexttoke]);
1711 /* interpolated case modifiers like \L \U, including \Q and \E.
1712 when we get here, PL_bufptr is at the \
1714 case LEX_INTERPCASEMOD:
1716 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1717 croak("panic: INTERPCASEMOD");
1719 /* handle \E or end of string */
1720 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1724 if (PL_lex_casemods) {
1725 oldmod = PL_lex_casestack[--PL_lex_casemods];
1726 PL_lex_casestack[PL_lex_casemods] = '\0';
1728 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1730 PL_lex_state = LEX_INTERPCONCAT;
1734 if (PL_bufptr != PL_bufend)
1736 PL_lex_state = LEX_INTERPCONCAT;
1737 return yylex(PERL_YYLEX_PARAM_DECL);
1741 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1742 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1743 if (strchr("LU", *s) &&
1744 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1746 PL_lex_casestack[--PL_lex_casemods] = '\0';
1749 if (PL_lex_casemods > 10) {
1750 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1751 if (newlb != PL_lex_casestack) {
1753 PL_lex_casestack = newlb;
1756 PL_lex_casestack[PL_lex_casemods++] = *s;
1757 PL_lex_casestack[PL_lex_casemods] = '\0';
1758 PL_lex_state = LEX_INTERPCONCAT;
1759 PL_nextval[PL_nexttoke].ival = 0;
1762 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1764 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1766 PL_nextval[PL_nexttoke].ival = OP_LC;
1768 PL_nextval[PL_nexttoke].ival = OP_UC;
1770 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1772 croak("panic: yylex");
1775 if (PL_lex_starts) {
1781 return yylex(PERL_YYLEX_PARAM_DECL);
1784 case LEX_INTERPPUSH:
1785 return sublex_push();
1787 case LEX_INTERPSTART:
1788 if (PL_bufptr == PL_bufend)
1789 return sublex_done();
1791 PL_lex_dojoin = (*PL_bufptr == '@');
1792 PL_lex_state = LEX_INTERPNORMAL;
1793 if (PL_lex_dojoin) {
1794 PL_nextval[PL_nexttoke].ival = 0;
1797 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1798 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1799 force_next(PRIVATEREF);
1801 force_ident("\"", '$');
1802 #endif /* USE_THREADS */
1803 PL_nextval[PL_nexttoke].ival = 0;
1805 PL_nextval[PL_nexttoke].ival = 0;
1807 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1810 if (PL_lex_starts++) {
1814 return yylex(PERL_YYLEX_PARAM_DECL);
1816 case LEX_INTERPENDMAYBE:
1817 if (intuit_more(PL_bufptr)) {
1818 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1824 if (PL_lex_dojoin) {
1825 PL_lex_dojoin = FALSE;
1826 PL_lex_state = LEX_INTERPCONCAT;
1830 case LEX_INTERPCONCAT:
1832 if (PL_lex_brackets)
1833 croak("panic: INTERPCONCAT");
1835 if (PL_bufptr == PL_bufend)
1836 return sublex_done();
1838 if (SvIVX(PL_linestr) == '\'') {
1839 SV *sv = newSVsv(PL_linestr);
1842 else if ( PL_hints & HINT_NEW_RE )
1843 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1844 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1848 s = scan_const(PL_bufptr);
1850 PL_lex_state = LEX_INTERPCASEMOD;
1852 PL_lex_state = LEX_INTERPSTART;
1855 if (s != PL_bufptr) {
1856 PL_nextval[PL_nexttoke] = yylval;
1859 if (PL_lex_starts++)
1863 return yylex(PERL_YYLEX_PARAM_DECL);
1867 return yylex(PERL_YYLEX_PARAM_DECL);
1869 PL_lex_state = LEX_NORMAL;
1870 s = scan_formline(PL_bufptr);
1871 if (!PL_lex_formbrack)
1877 PL_oldoldbufptr = PL_oldbufptr;
1880 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1886 if (isIDFIRST_lazy(s))
1888 croak("Unrecognized character \\x%02X", *s & 255);
1891 goto fake_eof; /* emulate EOF on ^D or ^Z */
1896 if (PL_lex_brackets)
1897 yyerror("Missing right bracket");
1900 if (s++ < PL_bufend)
1901 goto retry; /* ignore stray nulls */
1904 if (!PL_in_eval && !PL_preambled) {
1905 PL_preambled = TRUE;
1906 sv_setpv(PL_linestr,incl_perldb());
1907 if (SvCUR(PL_linestr))
1908 sv_catpv(PL_linestr,";");
1910 while(AvFILLp(PL_preambleav) >= 0) {
1911 SV *tmpsv = av_shift(PL_preambleav);
1912 sv_catsv(PL_linestr, tmpsv);
1913 sv_catpv(PL_linestr, ";");
1916 sv_free((SV*)PL_preambleav);
1917 PL_preambleav = NULL;
1919 if (PL_minus_n || PL_minus_p) {
1920 sv_catpv(PL_linestr, "LINE: while (<>) {");
1922 sv_catpv(PL_linestr,"chomp;");
1924 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1926 GvIMPORTED_AV_on(gv);
1928 if (strchr("/'\"", *PL_splitstr)
1929 && strchr(PL_splitstr + 1, *PL_splitstr))
1930 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1933 s = "'~#\200\1'"; /* surely one char is unused...*/
1934 while (s[1] && strchr(PL_splitstr, *s)) s++;
1936 sv_catpvf(PL_linestr, "@F=split(%s%c",
1937 "q" + (delim == '\''), delim);
1938 for (s = PL_splitstr; *s; s++) {
1940 sv_catpvn(PL_linestr, "\\", 1);
1941 sv_catpvn(PL_linestr, s, 1);
1943 sv_catpvf(PL_linestr, "%c);", delim);
1947 sv_catpv(PL_linestr,"@F=split(' ');");
1950 sv_catpv(PL_linestr, "\n");
1951 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1952 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1953 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1954 SV *sv = NEWSV(85,0);
1956 sv_upgrade(sv, SVt_PVMG);
1957 sv_setsv(sv,PL_linestr);
1958 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1963 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1966 if (PL_preprocess && !PL_in_eval)
1967 (void)PerlProc_pclose(PL_rsfp);
1968 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1969 PerlIO_clearerr(PL_rsfp);
1971 (void)PerlIO_close(PL_rsfp);
1973 PL_doextract = FALSE;
1975 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1976 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1977 sv_catpv(PL_linestr,";}");
1978 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1979 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1980 PL_minus_n = PL_minus_p = 0;
1983 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1984 sv_setpv(PL_linestr,"");
1985 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1988 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1989 PL_doextract = FALSE;
1991 /* Incest with pod. */
1992 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1993 sv_setpv(PL_linestr, "");
1994 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1995 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1996 PL_doextract = FALSE;
2000 } while (PL_doextract);
2001 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2002 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2003 SV *sv = NEWSV(85,0);
2005 sv_upgrade(sv, SVt_PVMG);
2006 sv_setsv(sv,PL_linestr);
2007 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2009 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2010 if (PL_curcop->cop_line == 1) {
2011 while (s < PL_bufend && isSPACE(*s))
2013 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2017 if (*s == '#' && *(s+1) == '!')
2019 #ifdef ALTERNATE_SHEBANG
2021 static char as[] = ALTERNATE_SHEBANG;
2022 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2023 d = s + (sizeof(as) - 1);
2025 #endif /* ALTERNATE_SHEBANG */
2034 while (*d && !isSPACE(*d))
2038 #ifdef ARG_ZERO_IS_SCRIPT
2039 if (ipathend > ipath) {
2041 * HP-UX (at least) sets argv[0] to the script name,
2042 * which makes $^X incorrect. And Digital UNIX and Linux,
2043 * at least, set argv[0] to the basename of the Perl
2044 * interpreter. So, having found "#!", we'll set it right.
2046 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2047 assert(SvPOK(x) || SvGMAGICAL(x));
2048 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2049 sv_setpvn(x, ipath, ipathend - ipath);
2052 TAINT_NOT; /* $^X is always tainted, but that's OK */
2054 #endif /* ARG_ZERO_IS_SCRIPT */
2059 d = instr(s,"perl -");
2061 d = instr(s,"perl");
2062 #ifdef ALTERNATE_SHEBANG
2064 * If the ALTERNATE_SHEBANG on this system starts with a
2065 * character that can be part of a Perl expression, then if
2066 * we see it but not "perl", we're probably looking at the
2067 * start of Perl code, not a request to hand off to some
2068 * other interpreter. Similarly, if "perl" is there, but
2069 * not in the first 'word' of the line, we assume the line
2070 * contains the start of the Perl program.
2072 if (d && *s != '#') {
2074 while (*c && !strchr("; \t\r\n\f\v#", *c))
2077 d = Nullch; /* "perl" not in first word; ignore */
2079 *s = '#'; /* Don't try to parse shebang line */
2081 #endif /* ALTERNATE_SHEBANG */
2086 !instr(s,"indir") &&
2087 instr(PL_origargv[0],"perl"))
2093 while (s < PL_bufend && isSPACE(*s))
2095 if (s < PL_bufend) {
2096 Newz(899,newargv,PL_origargc+3,char*);
2098 while (s < PL_bufend && !isSPACE(*s))
2101 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2104 newargv = PL_origargv;
2106 execv(ipath, newargv);
2107 croak("Can't exec %s", ipath);
2110 U32 oldpdb = PL_perldb;
2111 bool oldn = PL_minus_n;
2112 bool oldp = PL_minus_p;
2114 while (*d && !isSPACE(*d)) d++;
2115 while (*d == ' ' || *d == '\t') d++;
2119 if (*d == 'M' || *d == 'm') {
2121 while (*d && !isSPACE(*d)) d++;
2122 croak("Too late for \"-%.*s\" option",
2125 d = moreswitches(d);
2127 if (PERLDB_LINE && !oldpdb ||
2128 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2129 /* if we have already added "LINE: while (<>) {",
2130 we must not do it again */
2132 sv_setpv(PL_linestr, "");
2133 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2134 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2135 PL_preambled = FALSE;
2137 (void)gv_fetchfile(PL_origfilename);
2144 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2146 PL_lex_state = LEX_FORMLINE;
2147 return yylex(PERL_YYLEX_PARAM_DECL);
2151 #ifdef PERL_STRICT_CR
2152 warn("Illegal character \\%03o (carriage return)", '\r');
2154 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2156 case ' ': case '\t': case '\f': case 013:
2161 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2163 while (s < d && *s != '\n')
2168 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2170 PL_lex_state = LEX_FORMLINE;
2171 return yylex(PERL_YYLEX_PARAM_DECL);
2180 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2185 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2188 if (strnEQ(s,"=>",2)) {
2189 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2190 OPERATOR('-'); /* unary minus */
2192 PL_last_uni = PL_oldbufptr;
2193 PL_last_lop_op = OP_FTEREAD; /* good enough */
2195 case 'r': FTST(OP_FTEREAD);
2196 case 'w': FTST(OP_FTEWRITE);
2197 case 'x': FTST(OP_FTEEXEC);
2198 case 'o': FTST(OP_FTEOWNED);
2199 case 'R': FTST(OP_FTRREAD);
2200 case 'W': FTST(OP_FTRWRITE);
2201 case 'X': FTST(OP_FTREXEC);
2202 case 'O': FTST(OP_FTROWNED);
2203 case 'e': FTST(OP_FTIS);
2204 case 'z': FTST(OP_FTZERO);
2205 case 's': FTST(OP_FTSIZE);
2206 case 'f': FTST(OP_FTFILE);
2207 case 'd': FTST(OP_FTDIR);
2208 case 'l': FTST(OP_FTLINK);
2209 case 'p': FTST(OP_FTPIPE);
2210 case 'S': FTST(OP_FTSOCK);
2211 case 'u': FTST(OP_FTSUID);
2212 case 'g': FTST(OP_FTSGID);
2213 case 'k': FTST(OP_FTSVTX);
2214 case 'b': FTST(OP_FTBLK);
2215 case 'c': FTST(OP_FTCHR);
2216 case 't': FTST(OP_FTTTY);
2217 case 'T': FTST(OP_FTTEXT);
2218 case 'B': FTST(OP_FTBINARY);
2219 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2220 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2221 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2223 croak("Unrecognized file test: -%c", (int)tmp);
2230 if (PL_expect == XOPERATOR)
2235 else if (*s == '>') {
2238 if (isIDFIRST_lazy(s)) {
2239 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2247 if (PL_expect == XOPERATOR)
2250 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2252 OPERATOR('-'); /* unary minus */
2259 if (PL_expect == XOPERATOR)
2264 if (PL_expect == XOPERATOR)
2267 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2273 if (PL_expect != XOPERATOR) {
2274 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2275 PL_expect = XOPERATOR;
2276 force_ident(PL_tokenbuf, '*');
2289 if (PL_expect == XOPERATOR) {
2293 PL_tokenbuf[0] = '%';
2294 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2295 if (!PL_tokenbuf[1]) {
2297 yyerror("Final % should be \\% or %name");
2300 PL_pending_ident = '%';
2322 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2323 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2328 if (PL_curcop->cop_line < PL_copline)
2329 PL_copline = PL_curcop->cop_line;
2340 if (PL_lex_brackets <= 0)
2341 yyerror("Unmatched right bracket");
2344 if (PL_lex_state == LEX_INTERPNORMAL) {
2345 if (PL_lex_brackets == 0) {
2346 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2347 PL_lex_state = LEX_INTERPEND;
2354 if (PL_lex_brackets > 100) {
2355 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2356 if (newlb != PL_lex_brackstack) {
2358 PL_lex_brackstack = newlb;
2361 switch (PL_expect) {
2363 if (PL_lex_formbrack) {
2367 if (PL_oldoldbufptr == PL_last_lop)
2368 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2370 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2371 OPERATOR(HASHBRACK);
2373 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2376 PL_tokenbuf[0] = '\0';
2377 if (d < PL_bufend && *d == '-') {
2378 PL_tokenbuf[0] = '-';
2380 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2383 if (d < PL_bufend && isIDFIRST_lazy(d)) {
2384 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2386 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2389 char minus = (PL_tokenbuf[0] == '-');
2390 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2397 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2401 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2406 if (PL_oldoldbufptr == PL_last_lop)
2407 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2409 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2412 OPERATOR(HASHBRACK);
2413 /* This hack serves to disambiguate a pair of curlies
2414 * as being a block or an anon hash. Normally, expectation
2415 * determines that, but in cases where we're not in a
2416 * position to expect anything in particular (like inside
2417 * eval"") we have to resolve the ambiguity. This code
2418 * covers the case where the first term in the curlies is a
2419 * quoted string. Most other cases need to be explicitly
2420 * disambiguated by prepending a `+' before the opening
2421 * curly in order to force resolution as an anon hash.
2423 * XXX should probably propagate the outer expectation
2424 * into eval"" to rely less on this hack, but that could
2425 * potentially break current behavior of eval"".
2429 if (*s == '\'' || *s == '"' || *s == '`') {
2430 /* common case: get past first string, handling escapes */
2431 for (t++; t < PL_bufend && *t != *s;)
2432 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2436 else if (*s == 'q') {
2439 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2440 && !isALNUM(*t)))) {
2442 char open, close, term;
2445 while (t < PL_bufend && isSPACE(*t))
2449 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2453 for (t++; t < PL_bufend; t++) {
2454 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2456 else if (*t == open)
2460 for (t++; t < PL_bufend; t++) {
2461 if (*t == '\\' && t+1 < PL_bufend)
2463 else if (*t == close && --brackets <= 0)
2465 else if (*t == open)
2471 else if (isIDFIRST_lazy(s)) {
2472 for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2474 while (t < PL_bufend && isSPACE(*t))
2476 /* if comma follows first term, call it an anon hash */
2477 /* XXX it could be a comma expression with loop modifiers */
2478 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2479 || (*t == '=' && t[1] == '>')))
2480 OPERATOR(HASHBRACK);
2481 if (PL_expect == XREF)
2482 PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2484 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2490 yylval.ival = PL_curcop->cop_line;
2491 if (isSPACE(*s) || *s == '#')
2492 PL_copline = NOLINE; /* invalidate current command line number */
2497 if (PL_lex_brackets <= 0)
2498 yyerror("Unmatched right bracket");
2500 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2501 if (PL_lex_brackets < PL_lex_formbrack)
2502 PL_lex_formbrack = 0;
2503 if (PL_lex_state == LEX_INTERPNORMAL) {
2504 if (PL_lex_brackets == 0) {
2505 if (PL_lex_fakebrack) {
2506 PL_lex_state = LEX_INTERPEND;
2508 return yylex(PERL_YYLEX_PARAM_DECL); /* ignore fake brackets */
2510 if (*s == '-' && s[1] == '>')
2511 PL_lex_state = LEX_INTERPENDMAYBE;
2512 else if (*s != '[' && *s != '{')
2513 PL_lex_state = LEX_INTERPEND;
2516 if (PL_lex_brackets < PL_lex_fakebrack) {
2518 PL_lex_fakebrack = 0;
2519 return yylex(PERL_YYLEX_PARAM_DECL); /* ignore fake brackets */
2529 if (PL_expect == XOPERATOR) {
2530 if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2531 PL_curcop->cop_line--;
2532 warner(WARN_SEMICOLON, warn_nosemi);
2533 PL_curcop->cop_line++;
2538 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2540 PL_expect = XOPERATOR;
2541 force_ident(PL_tokenbuf, '&');
2545 yylval.ival = (OPpENTERSUB_AMPER<<8);
2564 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2565 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2567 if (PL_expect == XSTATE && isALPHA(tmp) &&
2568 (s == PL_linestart+1 || s[-2] == '\n') )
2570 if (PL_in_eval && !PL_rsfp) {
2575 if (strnEQ(s,"=cut",4)) {
2589 PL_doextract = TRUE;
2592 if (PL_lex_brackets < PL_lex_formbrack) {
2594 #ifdef PERL_STRICT_CR
2595 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2597 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2599 if (*t == '\n' || *t == '#') {
2617 if (PL_expect != XOPERATOR) {
2618 if (s[1] != '<' && !strchr(s,'>'))
2621 s = scan_heredoc(s);
2623 s = scan_inputsymbol(s);
2624 TERM(sublex_start());
2629 SHop(OP_LEFT_SHIFT);
2643 SHop(OP_RIGHT_SHIFT);
2652 if (PL_expect == XOPERATOR) {
2653 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2656 return ','; /* grandfather non-comma-format format */
2660 if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2661 if (PL_expect == XOPERATOR)
2662 no_op("Array length", PL_bufptr);
2663 PL_tokenbuf[0] = '@';
2664 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2666 if (!PL_tokenbuf[1])
2668 PL_expect = XOPERATOR;
2669 PL_pending_ident = '#';
2673 if (PL_expect == XOPERATOR)
2674 no_op("Scalar", PL_bufptr);
2675 PL_tokenbuf[0] = '$';
2676 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2677 if (!PL_tokenbuf[1]) {
2679 yyerror("Final $ should be \\$ or $name");
2683 /* This kludge not intended to be bulletproof. */
2684 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2685 yylval.opval = newSVOP(OP_CONST, 0,
2686 newSViv((IV)PL_compiling.cop_arybase));
2687 yylval.opval->op_private = OPpCONST_ARYBASE;
2692 if (PL_lex_state == LEX_NORMAL)
2695 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2698 PL_tokenbuf[0] = '@';
2699 if (ckWARN(WARN_SYNTAX)) {
2701 isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2704 PL_bufptr = skipspace(PL_bufptr);
2705 while (t < PL_bufend && *t != ']')
2708 "Multidimensional syntax %.*s not supported",
2709 (t - PL_bufptr) + 1, PL_bufptr);
2713 else if (*s == '{') {
2714 PL_tokenbuf[0] = '%';
2715 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2716 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2718 char tmpbuf[sizeof PL_tokenbuf];
2720 for (t++; isSPACE(*t); t++) ;
2721 if (isIDFIRST_lazy(t)) {
2722 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2723 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2725 "You need to quote \"%s\"", tmpbuf);
2731 PL_expect = XOPERATOR;
2732 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2733 bool islop = (PL_last_lop == PL_oldoldbufptr);
2734 if (!islop || PL_last_lop_op == OP_GREPSTART)
2735 PL_expect = XOPERATOR;
2736 else if (strchr("$@\"'`q", *s))
2737 PL_expect = XTERM; /* e.g. print $fh "foo" */
2738 else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2739 PL_expect = XTERM; /* e.g. print $fh &sub */
2740 else if (isIDFIRST_lazy(s)) {
2741 char tmpbuf[sizeof PL_tokenbuf];
2742 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2743 if (tmp = keyword(tmpbuf, len)) {
2744 /* binary operators exclude handle interpretations */
2756 PL_expect = XTERM; /* e.g. print $fh length() */
2761 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2762 if (gv && GvCVu(gv))
2763 PL_expect = XTERM; /* e.g. print $fh subr() */
2766 else if (isDIGIT(*s))
2767 PL_expect = XTERM; /* e.g. print $fh 3 */
2768 else if (*s == '.' && isDIGIT(s[1]))
2769 PL_expect = XTERM; /* e.g. print $fh .3 */
2770 else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2771 PL_expect = XTERM; /* e.g. print $fh -1 */
2772 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2773 PL_expect = XTERM; /* print $fh <<"EOF" */
2775 PL_pending_ident = '$';
2779 if (PL_expect == XOPERATOR)
2781 PL_tokenbuf[0] = '@';
2782 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2783 if (!PL_tokenbuf[1]) {
2785 yyerror("Final @ should be \\@ or @name");
2788 if (PL_lex_state == LEX_NORMAL)
2790 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2792 PL_tokenbuf[0] = '%';
2794 /* Warn about @ where they meant $. */
2795 if (ckWARN(WARN_SYNTAX)) {
2796 if (*s == '[' || *s == '{') {
2798 while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2800 if (*t == '}' || *t == ']') {
2802 PL_bufptr = skipspace(PL_bufptr);
2804 "Scalar value %.*s better written as $%.*s",
2805 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2810 PL_pending_ident = '@';
2813 case '/': /* may either be division or pattern */
2814 case '?': /* may either be conditional or pattern */
2815 if (PL_expect != XOPERATOR) {
2816 /* Disable warning on "study /blah/" */
2817 if (PL_oldoldbufptr == PL_last_uni
2818 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2819 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2821 s = scan_pat(s,OP_MATCH);
2822 TERM(sublex_start());
2830 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2831 #ifdef PERL_STRICT_CR
2834 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2836 && (s == PL_linestart || s[-1] == '\n') )
2838 PL_lex_formbrack = 0;
2842 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2848 yylval.ival = OPf_SPECIAL;
2854 if (PL_expect != XOPERATOR)
2859 case '0': case '1': case '2': case '3': case '4':
2860 case '5': case '6': case '7': case '8': case '9':
2862 if (PL_expect == XOPERATOR)
2868 if (PL_expect == XOPERATOR) {
2869 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2872 return ','; /* grandfather non-comma-format format */
2878 missingterm((char*)0);
2879 yylval.ival = OP_CONST;
2880 TERM(sublex_start());
2884 if (PL_expect == XOPERATOR) {
2885 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2888 return ','; /* grandfather non-comma-format format */
2894 missingterm((char*)0);
2895 yylval.ival = OP_CONST;
2896 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2897 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2898 yylval.ival = OP_STRINGIFY;
2902 TERM(sublex_start());
2906 if (PL_expect == XOPERATOR)
2907 no_op("Backticks",s);
2909 missingterm((char*)0);
2910 yylval.ival = OP_BACKTICK;
2912 TERM(sublex_start());
2916 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2917 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2919 if (PL_expect == XOPERATOR)
2920 no_op("Backslash",s);
2924 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2963 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2965 /* Some keywords can be followed by any delimiter, including ':' */
2966 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2967 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2968 (PL_tokenbuf[0] == 'q' &&
2969 strchr("qwxr", PL_tokenbuf[1]))));
2971 /* x::* is just a word, unless x is "CORE" */
2972 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2976 while (d < PL_bufend && isSPACE(*d))
2977 d++; /* no comments skipped here, or s### is misparsed */
2979 /* Is this a label? */
2980 if (!tmp && PL_expect == XSTATE
2981 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2983 yylval.pval = savepv(PL_tokenbuf);
2988 /* Check for keywords */
2989 tmp = keyword(PL_tokenbuf, len);
2991 /* Is this a word before a => operator? */
2992 if (strnEQ(d,"=>",2)) {
2994 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2995 yylval.opval->op_private = OPpCONST_BARE;
2999 if (tmp < 0) { /* second-class keyword? */
3000 GV *ogv = Nullgv; /* override (winner) */
3001 GV *hgv = Nullgv; /* hidden (loser) */
3002 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3004 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3007 if (GvIMPORTED_CV(gv))
3009 else if (! CvMETHOD(cv))
3013 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3014 (gv = *gvp) != (GV*)&PL_sv_undef &&
3015 GvCVu(gv) && GvIMPORTED_CV(gv))
3021 tmp = 0; /* overridden by import or by GLOBAL */
3024 && -tmp==KEY_lock /* XXX generalizable kludge */
3025 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3027 tmp = 0; /* any sub overrides "weak" keyword */
3029 else { /* no override */
3033 if (ckWARN(WARN_AMBIGUOUS) && hgv
3034 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3035 warner(WARN_AMBIGUOUS,
3036 "Ambiguous call resolved as CORE::%s(), %s",
3037 GvENAME(hgv), "qualify as such or use &");
3044 default: /* not a keyword */
3047 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3049 /* Get the rest if it looks like a package qualifier */
3051 if (*s == '\'' || *s == ':' && s[1] == ':') {
3053 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3056 croak("Bad name after %s%s", PL_tokenbuf,
3057 *s == '\'' ? "'" : "::");
3061 if (PL_expect == XOPERATOR) {
3062 if (PL_bufptr == PL_linestart) {
3063 PL_curcop->cop_line--;
3064 warner(WARN_SEMICOLON, warn_nosemi);
3065 PL_curcop->cop_line++;
3068 no_op("Bareword",s);
3071 /* Look for a subroutine with this name in current package,
3072 unless name is "Foo::", in which case Foo is a bearword
3073 (and a package name). */
3076 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3078 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3080 "Bareword \"%s\" refers to nonexistent package",
3083 PL_tokenbuf[len] = '\0';
3090 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3093 /* if we saw a global override before, get the right name */
3096 sv = newSVpv("CORE::GLOBAL::",14);
3097 sv_catpv(sv,PL_tokenbuf);
3100 sv = newSVpv(PL_tokenbuf,0);
3102 /* Presume this is going to be a bareword of some sort. */
3105 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3106 yylval.opval->op_private = OPpCONST_BARE;
3108 /* And if "Foo::", then that's what it certainly is. */
3113 /* See if it's the indirect object for a list operator. */
3115 if (PL_oldoldbufptr &&
3116 PL_oldoldbufptr < PL_bufptr &&
3117 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3118 /* NO SKIPSPACE BEFORE HERE! */
3120 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3121 || (PL_last_lop_op == OP_ENTERSUB
3123 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3125 bool immediate_paren = *s == '(';
3127 /* (Now we can afford to cross potential line boundary.) */
3130 /* Two barewords in a row may indicate method call. */
3132 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3135 /* If not a declared subroutine, it's an indirect object. */
3136 /* (But it's an indir obj regardless for sort.) */
3138 if ((PL_last_lop_op == OP_SORT ||
3139 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3140 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3141 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3146 /* If followed by a paren, it's certainly a subroutine. */
3148 PL_expect = XOPERATOR;
3152 if (gv && GvCVu(gv)) {
3154 if ((cv = GvCV(gv)) && SvPOK(cv))
3155 PL_last_proto = SvPV((SV*)cv, PL_na);
3156 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3157 if (*d == ')' && (sv = cv_const_sv(cv))) {
3162 PL_nextval[PL_nexttoke].opval = yylval.opval;
3163 PL_expect = XOPERATOR;
3166 PL_last_lop_op = OP_ENTERSUB;
3170 /* If followed by var or block, call it a method (unless sub) */
3172 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3173 PL_last_lop = PL_oldbufptr;
3174 PL_last_lop_op = OP_METHOD;
3178 /* If followed by a bareword, see if it looks like indir obj. */
3180 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3183 /* Not a method, so call it a subroutine (if defined) */
3185 if (gv && GvCVu(gv)) {
3187 if (lastchar == '-')
3188 warn("Ambiguous use of -%s resolved as -&%s()",
3189 PL_tokenbuf, PL_tokenbuf);
3190 PL_last_lop = PL_oldbufptr;
3191 PL_last_lop_op = OP_ENTERSUB;
3192 /* Check for a constant sub */
3194 if ((sv = cv_const_sv(cv))) {
3196 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3197 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3198 yylval.opval->op_private = 0;
3202 /* Resolve to GV now. */
3203 op_free(yylval.opval);
3204 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3205 PL_last_lop_op = OP_ENTERSUB;
3206 /* Is there a prototype? */
3209 PL_last_proto = SvPV((SV*)cv, len);
3212 if (strEQ(PL_last_proto, "$"))
3214 if (*PL_last_proto == '&' && *s == '{') {
3215 sv_setpv(PL_subname,"__ANON__");
3219 PL_last_proto = NULL;
3220 PL_nextval[PL_nexttoke].opval = yylval.opval;
3226 if (PL_hints & HINT_STRICT_SUBS &&
3229 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3230 PL_last_lop_op != OP_ACCEPT &&
3231 PL_last_lop_op != OP_PIPE_OP &&
3232 PL_last_lop_op != OP_SOCKPAIR &&
3233 !(PL_last_lop_op == OP_ENTERSUB
3235 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3238 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3243 /* Call it a bare word */
3246 if (ckWARN(WARN_RESERVED)) {
3247 if (lastchar != '-') {
3248 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3250 warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
3255 if (lastchar && strchr("*%&", lastchar)) {
3256 warn("Operator or semicolon missing before %c%s",
3257 lastchar, PL_tokenbuf);
3258 warn("Ambiguous use of %c resolved as operator %c",
3259 lastchar, lastchar);
3265 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3266 newSVsv(GvSV(PL_curcop->cop_filegv)));
3270 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3271 newSVpvf("%ld", (long)PL_curcop->cop_line));
3274 case KEY___PACKAGE__:
3275 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3277 ? newSVsv(PL_curstname)
3286 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3287 char *pname = "main";
3288 if (PL_tokenbuf[2] == 'D')
3289 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3290 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3293 GvIOp(gv) = newIO();
3294 IoIFP(GvIOp(gv)) = PL_rsfp;
3295 #if defined(HAS_FCNTL) && defined(F_SETFD)
3297 int fd = PerlIO_fileno(PL_rsfp);
3298 fcntl(fd,F_SETFD,fd >= 3);
3301 /* Mark this internal pseudo-handle as clean */
3302 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3304 IoTYPE(GvIOp(gv)) = '|';
3305 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3306 IoTYPE(GvIOp(gv)) = '-';
3308 IoTYPE(GvIOp(gv)) = '<';
3319 if (PL_expect == XSTATE) {
3326 if (*s == ':' && s[1] == ':') {
3329 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3330 tmp = keyword(PL_tokenbuf, len);
3344 LOP(OP_ACCEPT,XTERM);
3350 LOP(OP_ATAN2,XTERM);
3359 LOP(OP_BLESS,XTERM);
3368 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3385 if (!PL_cryptseen++)
3388 LOP(OP_CRYPT,XTERM);
3391 if (ckWARN(WARN_OCTAL)) {
3392 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3393 if (*d != '0' && isDIGIT(*d))
3394 yywarn("chmod: mode argument is missing initial 0");
3396 LOP(OP_CHMOD,XTERM);
3399 LOP(OP_CHOWN,XTERM);
3402 LOP(OP_CONNECT,XTERM);
3418 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3422 PL_hints |= HINT_BLOCK_SCOPE;
3432 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3433 LOP(OP_DBMOPEN,XTERM);
3439 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3446 yylval.ival = PL_curcop->cop_line;
3460 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3461 UNIBRACK(OP_ENTEREVAL);
3476 case KEY_endhostent:
3482 case KEY_endservent:
3485 case KEY_endprotoent:
3496 yylval.ival = PL_curcop->cop_line;
3498 if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3500 if ((PL_bufend - p) >= 3 &&
3501 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3504 if (isIDFIRST_lazy(p))
3505 croak("Missing $ on loop variable");
3510 LOP(OP_FORMLINE,XTERM);
3516 LOP(OP_FCNTL,XTERM);
3522 LOP(OP_FLOCK,XTERM);
3531 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3534 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3549 case KEY_getpriority:
3550 LOP(OP_GETPRIORITY,XTERM);
3552 case KEY_getprotobyname:
3555 case KEY_getprotobynumber:
3556 LOP(OP_GPBYNUMBER,XTERM);
3558 case KEY_getprotoent:
3570 case KEY_getpeername:
3571 UNI(OP_GETPEERNAME);
3573 case KEY_gethostbyname:
3576 case KEY_gethostbyaddr:
3577 LOP(OP_GHBYADDR,XTERM);
3579 case KEY_gethostent:
3582 case KEY_getnetbyname:
3585 case KEY_getnetbyaddr:
3586 LOP(OP_GNBYADDR,XTERM);
3591 case KEY_getservbyname:
3592 LOP(OP_GSBYNAME,XTERM);
3594 case KEY_getservbyport:
3595 LOP(OP_GSBYPORT,XTERM);
3597 case KEY_getservent:
3600 case KEY_getsockname:
3601 UNI(OP_GETSOCKNAME);
3603 case KEY_getsockopt:
3604 LOP(OP_GSOCKOPT,XTERM);
3626 yylval.ival = PL_curcop->cop_line;
3630 LOP(OP_INDEX,XTERM);
3636 LOP(OP_IOCTL,XTERM);
3648 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3679 LOP(OP_LISTEN,XTERM);
3688 s = scan_pat(s,OP_MATCH);
3689 TERM(sublex_start());
3692 LOP(OP_MAPSTART, XREF);
3695 LOP(OP_MKDIR,XTERM);
3698 LOP(OP_MSGCTL,XTERM);
3701 LOP(OP_MSGGET,XTERM);
3704 LOP(OP_MSGRCV,XTERM);
3707 LOP(OP_MSGSND,XTERM);
3712 if (isIDFIRST_lazy(s)) {
3713 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3714 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3715 if (!PL_in_my_stash) {
3718 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3725 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3732 if (PL_expect != XSTATE)
3733 yyerror("\"no\" not allowed in expression");
3734 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3735 s = force_version(s);
3744 if (isIDFIRST_lazy(s)) {
3746 for (d = s; isALNUM_lazy(d); d++) ;
3748 if (strchr("|&*+-=!?:.", *t))
3749 warn("Precedence problem: open %.*s should be open(%.*s)",
3755 yylval.ival = OP_OR;
3765 LOP(OP_OPEN_DIR,XTERM);
3768 checkcomma(s,PL_tokenbuf,"filehandle");
3772 checkcomma(s,PL_tokenbuf,"filehandle");
3791 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3795 LOP(OP_PIPE_OP,XTERM);
3800 missingterm((char*)0);
3801 yylval.ival = OP_CONST;
3802 TERM(sublex_start());
3810 missingterm((char*)0);
3811 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3812 d = SvPV_force(PL_lex_stuff, len);
3813 for (; len; --len, ++d) {
3816 "Possible attempt to separate words with commas");
3821 "Possible attempt to put comments in qw() list");
3827 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3828 PL_lex_stuff = Nullsv;
3831 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3834 yylval.ival = OP_SPLIT;
3838 PL_last_lop = PL_oldbufptr;
3839 PL_last_lop_op = OP_SPLIT;
3845 missingterm((char*)0);
3846 yylval.ival = OP_STRINGIFY;
3847 if (SvIVX(PL_lex_stuff) == '\'')
3848 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3849 TERM(sublex_start());
3852 s = scan_pat(s,OP_QR);
3853 TERM(sublex_start());
3858 missingterm((char*)0);
3859 yylval.ival = OP_BACKTICK;
3861 TERM(sublex_start());
3867 *PL_tokenbuf = '\0';
3868 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3869 if (isIDFIRST_lazy(PL_tokenbuf))
3870 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3872 yyerror("<> should be quotes");
3879 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3883 LOP(OP_RENAME,XTERM);
3892 LOP(OP_RINDEX,XTERM);
3915 LOP(OP_REVERSE,XTERM);
3926 TERM(sublex_start());
3928 TOKEN(1); /* force error */
3937 LOP(OP_SELECT,XTERM);
3943 LOP(OP_SEMCTL,XTERM);
3946 LOP(OP_SEMGET,XTERM);
3949 LOP(OP_SEMOP,XTERM);
3955 LOP(OP_SETPGRP,XTERM);
3957 case KEY_setpriority:
3958 LOP(OP_SETPRIORITY,XTERM);
3960 case KEY_sethostent:
3966 case KEY_setservent:
3969 case KEY_setprotoent:
3979 LOP(OP_SEEKDIR,XTERM);
3981 case KEY_setsockopt:
3982 LOP(OP_SSOCKOPT,XTERM);
3988 LOP(OP_SHMCTL,XTERM);
3991 LOP(OP_SHMGET,XTERM);
3994 LOP(OP_SHMREAD,XTERM);
3997 LOP(OP_SHMWRITE,XTERM);
4000 LOP(OP_SHUTDOWN,XTERM);
4009 LOP(OP_SOCKET,XTERM);
4011 case KEY_socketpair:
4012 LOP(OP_SOCKPAIR,XTERM);
4015 checkcomma(s,PL_tokenbuf,"subroutine name");
4017 if (*s == ';' || *s == ')') /* probably a close */
4018 croak("sort is now a reserved word");
4020 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4024 LOP(OP_SPLIT,XTERM);
4027 LOP(OP_SPRINTF,XTERM);
4030 LOP(OP_SPLICE,XTERM);
4046 LOP(OP_SUBSTR,XTERM);
4053 if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4054 char tmpbuf[sizeof PL_tokenbuf];
4056 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4057 if (strchr(tmpbuf, ':'))
4058 sv_setpv(PL_subname, tmpbuf);
4060 sv_setsv(PL_subname,PL_curstname);
4061 sv_catpvn(PL_subname,"::",2);
4062 sv_catpvn(PL_subname,tmpbuf,len);
4064 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4068 PL_expect = XTERMBLOCK;
4069 sv_setpv(PL_subname,"?");
4072 if (tmp == KEY_format) {
4075 PL_lex_formbrack = PL_lex_brackets + 1;
4079 /* Look for a prototype */
4086 SvREFCNT_dec(PL_lex_stuff);
4087 PL_lex_stuff = Nullsv;
4088 croak("Prototype not terminated");
4091 d = SvPVX(PL_lex_stuff);
4093 for (p = d; *p; ++p) {
4098 SvCUR(PL_lex_stuff) = tmp;
4101 PL_nextval[1] = PL_nextval[0];
4102 PL_nexttype[1] = PL_nexttype[0];
4103 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4104 PL_nexttype[0] = THING;
4105 if (PL_nexttoke == 1) {
4106 PL_lex_defer = PL_lex_state;
4107 PL_lex_expect = PL_expect;
4108 PL_lex_state = LEX_KNOWNEXT;
4110 PL_lex_stuff = Nullsv;
4113 if (*SvPV(PL_subname,PL_na) == '?') {
4114 sv_setpv(PL_subname,"__ANON__");
4121 LOP(OP_SYSTEM,XREF);
4124 LOP(OP_SYMLINK,XTERM);
4127 LOP(OP_SYSCALL,XTERM);
4130 LOP(OP_SYSOPEN,XTERM);
4133 LOP(OP_SYSSEEK,XTERM);
4136 LOP(OP_SYSREAD,XTERM);
4139 LOP(OP_SYSWRITE,XTERM);
4143 TERM(sublex_start());
4164 LOP(OP_TRUNCATE,XTERM);
4176 yylval.ival = PL_curcop->cop_line;
4180 yylval.ival = PL_curcop->cop_line;
4184 LOP(OP_UNLINK,XTERM);
4190 LOP(OP_UNPACK,XTERM);
4193 LOP(OP_UTIME,XTERM);
4196 if (ckWARN(WARN_OCTAL)) {
4197 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4198 if (*d != '0' && isDIGIT(*d))
4199 yywarn("umask: argument is missing initial 0");
4204 LOP(OP_UNSHIFT,XTERM);
4207 if (PL_expect != XSTATE)
4208 yyerror("\"use\" not allowed in expression");
4211 s = force_version(s);
4212 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4213 PL_nextval[PL_nexttoke].opval = Nullop;
4218 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4219 s = force_version(s);
4232 yylval.ival = PL_curcop->cop_line;
4236 PL_hints |= HINT_BLOCK_SCOPE;
4243 LOP(OP_WAITPID,XTERM);
4251 static char ctl_l[2];
4253 if (ctl_l[0] == '\0')
4254 ctl_l[0] = toCTRL('L');
4255 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4258 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4263 if (PL_expect == XOPERATOR)
4269 yylval.ival = OP_XOR;
4274 TERM(sublex_start());
4280 keyword(register char *d, I32 len)
4285 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4286 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4287 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4288 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4289 if (strEQ(d,"__END__")) return KEY___END__;
4293 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4298 if (strEQ(d,"and")) return -KEY_and;
4299 if (strEQ(d,"abs")) return -KEY_abs;
4302 if (strEQ(d,"alarm")) return -KEY_alarm;
4303 if (strEQ(d,"atan2")) return -KEY_atan2;
4306 if (strEQ(d,"accept")) return -KEY_accept;
4311 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4314 if (strEQ(d,"bless")) return -KEY_bless;
4315 if (strEQ(d,"bind")) return -KEY_bind;
4316 if (strEQ(d,"binmode")) return -KEY_binmode;
4319 if (strEQ(d,"CORE")) return -KEY_CORE;
4324 if (strEQ(d,"cmp")) return -KEY_cmp;
4325 if (strEQ(d,"chr")) return -KEY_chr;
4326 if (strEQ(d,"cos")) return -KEY_cos;
4329 if (strEQ(d,"chop")) return KEY_chop;
4332 if (strEQ(d,"close")) return -KEY_close;
4333 if (strEQ(d,"chdir")) return -KEY_chdir;
4334 if (strEQ(d,"chomp")) return KEY_chomp;
4335 if (strEQ(d,"chmod")) return -KEY_chmod;
4336 if (strEQ(d,"chown")) return -KEY_chown;
4337 if (strEQ(d,"crypt")) return -KEY_crypt;
4340 if (strEQ(d,"chroot")) return -KEY_chroot;
4341 if (strEQ(d,"caller")) return -KEY_caller;
4344 if (strEQ(d,"connect")) return -KEY_connect;
4347 if (strEQ(d,"closedir")) return -KEY_closedir;
4348 if (strEQ(d,"continue")) return -KEY_continue;
4353 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4358 if (strEQ(d,"do")) return KEY_do;
4361 if (strEQ(d,"die")) return -KEY_die;
4364 if (strEQ(d,"dump")) return -KEY_dump;
4367 if (strEQ(d,"delete")) return KEY_delete;
4370 if (strEQ(d,"defined")) return KEY_defined;
4371 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4374 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4379 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4380 if (strEQ(d,"END")) return KEY_END;
4385 if (strEQ(d,"eq")) return -KEY_eq;
4388 if (strEQ(d,"eof")) return -KEY_eof;
4389 if (strEQ(d,"exp")) return -KEY_exp;
4392 if (strEQ(d,"else")) return KEY_else;
4393 if (strEQ(d,"exit")) return -KEY_exit;
4394 if (strEQ(d,"eval")) return KEY_eval;
4395 if (strEQ(d,"exec")) return -KEY_exec;
4396 if (strEQ(d,"each")) return KEY_each;
4399 if (strEQ(d,"elsif")) return KEY_elsif;
4402 if (strEQ(d,"exists")) return KEY_exists;
4403 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4406 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4407 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4410 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4413 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4414 if (strEQ(d,"endservent")) return -KEY_endservent;
4417 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4424 if (strEQ(d,"for")) return KEY_for;
4427 if (strEQ(d,"fork")) return -KEY_fork;
4430 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4431 if (strEQ(d,"flock")) return -KEY_flock;
4434 if (strEQ(d,"format")) return KEY_format;
4435 if (strEQ(d,"fileno")) return -KEY_fileno;
4438 if (strEQ(d,"foreach")) return KEY_foreach;
4441 if (strEQ(d,"formline")) return -KEY_formline;
4447 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4448 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4452 if (strnEQ(d,"get",3)) {
4457 if (strEQ(d,"ppid")) return -KEY_getppid;
4458 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4461 if (strEQ(d,"pwent")) return -KEY_getpwent;
4462 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4463 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4466 if (strEQ(d,"peername")) return -KEY_getpeername;
4467 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4468 if (strEQ(d,"priority")) return -KEY_getpriority;
4471 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4474 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4478 else if (*d == 'h') {
4479 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4480 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4481 if (strEQ(d,"hostent")) return -KEY_gethostent;
4483 else if (*d == 'n') {
4484 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4485 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4486 if (strEQ(d,"netent")) return -KEY_getnetent;
4488 else if (*d == 's') {
4489 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4490 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4491 if (strEQ(d,"servent")) return -KEY_getservent;
4492 if (strEQ(d,"sockname")) return -KEY_getsockname;
4493 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4495 else if (*d == 'g') {
4496 if (strEQ(d,"grent")) return -KEY_getgrent;
4497 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4498 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4500 else if (*d == 'l') {
4501 if (strEQ(d,"login")) return -KEY_getlogin;
4503 else if (strEQ(d,"c")) return -KEY_getc;
4508 if (strEQ(d,"gt")) return -KEY_gt;
4509 if (strEQ(d,"ge")) return -KEY_ge;
4512 if (strEQ(d,"grep")) return KEY_grep;
4513 if (strEQ(d,"goto")) return KEY_goto;
4514 if (strEQ(d,"glob")) return KEY_glob;
4517 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4522 if (strEQ(d,"hex")) return -KEY_hex;
4525 if (strEQ(d,"INIT")) return KEY_INIT;
4530 if (strEQ(d,"if")) return KEY_if;
4533 if (strEQ(d,"int")) return -KEY_int;
4536 if (strEQ(d,"index")) return -KEY_index;
4537 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4542 if (strEQ(d,"join")) return -KEY_join;
4546 if (strEQ(d,"keys")) return KEY_keys;
4547 if (strEQ(d,"kill")) return -KEY_kill;
4552 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4553 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4559 if (strEQ(d,"lt")) return -KEY_lt;
4560 if (strEQ(d,"le")) return -KEY_le;
4561 if (strEQ(d,"lc")) return -KEY_lc;
4564 if (strEQ(d,"log")) return -KEY_log;
4567 if (strEQ(d,"last")) return KEY_last;
4568 if (strEQ(d,"link")) return -KEY_link;
4569 if (strEQ(d,"lock")) return -KEY_lock;
4572 if (strEQ(d,"local")) return KEY_local;
4573 if (strEQ(d,"lstat")) return -KEY_lstat;
4576 if (strEQ(d,"length")) return -KEY_length;
4577 if (strEQ(d,"listen")) return -KEY_listen;
4580 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4583 if (strEQ(d,"localtime")) return -KEY_localtime;
4589 case 1: return KEY_m;
4591 if (strEQ(d,"my")) return KEY_my;
4594 if (strEQ(d,"map")) return KEY_map;
4597 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4600 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4601 if (strEQ(d,"msgget")) return -KEY_msgget;
4602 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4603 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4608 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4611 if (strEQ(d,"next")) return KEY_next;
4612 if (strEQ(d,"ne")) return -KEY_ne;
4613 if (strEQ(d,"not")) return -KEY_not;
4614 if (strEQ(d,"no")) return KEY_no;
4619 if (strEQ(d,"or")) return -KEY_or;
4622 if (strEQ(d,"ord")) return -KEY_ord;
4623 if (strEQ(d,"oct")) return -KEY_oct;
4624 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4628 if (strEQ(d,"open")) return -KEY_open;
4631 if (strEQ(d,"opendir")) return -KEY_opendir;
4638 if (strEQ(d,"pop")) return KEY_pop;
4639 if (strEQ(d,"pos")) return KEY_pos;
4642 if (strEQ(d,"push")) return KEY_push;
4643 if (strEQ(d,"pack")) return -KEY_pack;
4644 if (strEQ(d,"pipe")) return -KEY_pipe;
4647 if (strEQ(d,"print")) return KEY_print;
4650 if (strEQ(d,"printf")) return KEY_printf;
4653 if (strEQ(d,"package")) return KEY_package;
4656 if (strEQ(d,"prototype")) return KEY_prototype;
4661 if (strEQ(d,"q")) return KEY_q;
4662 if (strEQ(d,"qr")) return KEY_qr;
4663 if (strEQ(d,"qq")) return KEY_qq;
4664 if (strEQ(d,"qw")) return KEY_qw;
4665 if (strEQ(d,"qx")) return KEY_qx;
4667 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4672 if (strEQ(d,"ref")) return -KEY_ref;
4675 if (strEQ(d,"read")) return -KEY_read;
4676 if (strEQ(d,"rand")) return -KEY_rand;
4677 if (strEQ(d,"recv")) return -KEY_recv;
4678 if (strEQ(d,"redo")) return KEY_redo;
4681 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4682 if (strEQ(d,"reset")) return -KEY_reset;
4685 if (strEQ(d,"return")) return KEY_return;
4686 if (strEQ(d,"rename")) return -KEY_rename;
4687 if (strEQ(d,"rindex")) return -KEY_rindex;
4690 if (strEQ(d,"require")) return -KEY_require;
4691 if (strEQ(d,"reverse")) return -KEY_reverse;
4692 if (strEQ(d,"readdir")) return -KEY_readdir;
4695 if (strEQ(d,"readlink")) return -KEY_readlink;
4696 if (strEQ(d,"readline")) return -KEY_readline;
4697 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4700 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4706 case 0: return KEY_s;
4708 if (strEQ(d,"scalar")) return KEY_scalar;
4713 if (strEQ(d,"seek")) return -KEY_seek;
4714 if (strEQ(d,"send")) return -KEY_send;
4717 if (strEQ(d,"semop")) return -KEY_semop;
4720 if (strEQ(d,"select")) return -KEY_select;
4721 if (strEQ(d,"semctl")) return -KEY_semctl;
4722 if (strEQ(d,"semget")) return -KEY_semget;
4725 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4726 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4729 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4730 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4733 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4736 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4737 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4738 if (strEQ(d,"setservent")) return -KEY_setservent;
4741 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4742 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4749 if (strEQ(d,"shift")) return KEY_shift;
4752 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4753 if (strEQ(d,"shmget")) return -KEY_shmget;
4756 if (strEQ(d,"shmread")) return -KEY_shmread;
4759 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4760 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4765 if (strEQ(d,"sin")) return -KEY_sin;
4768 if (strEQ(d,"sleep")) return -KEY_sleep;
4771 if (strEQ(d,"sort")) return KEY_sort;
4772 if (strEQ(d,"socket")) return -KEY_socket;
4773 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4776 if (strEQ(d,"split")) return KEY_split;
4777 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4778 if (strEQ(d,"splice")) return KEY_splice;
4781 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4784 if (strEQ(d,"srand")) return -KEY_srand;
4787 if (strEQ(d,"stat")) return -KEY_stat;
4788 if (strEQ(d,"study")) return KEY_study;
4791 if (strEQ(d,"substr")) return -KEY_substr;
4792 if (strEQ(d,"sub")) return KEY_sub;
4797 if (strEQ(d,"system")) return -KEY_system;
4800 if (strEQ(d,"symlink")) return -KEY_symlink;
4801 if (strEQ(d,"syscall")) return -KEY_syscall;
4802 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4803 if (strEQ(d,"sysread")) return -KEY_sysread;
4804 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4807 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4816 if (strEQ(d,"tr")) return KEY_tr;
4819 if (strEQ(d,"tie")) return KEY_tie;
4822 if (strEQ(d,"tell")) return -KEY_tell;
4823 if (strEQ(d,"tied")) return KEY_tied;
4824 if (strEQ(d,"time")) return -KEY_time;
4827 if (strEQ(d,"times")) return -KEY_times;
4830 if (strEQ(d,"telldir")) return -KEY_telldir;
4833 if (strEQ(d,"truncate")) return -KEY_truncate;
4840 if (strEQ(d,"uc")) return -KEY_uc;
4843 if (strEQ(d,"use")) return KEY_use;
4846 if (strEQ(d,"undef")) return KEY_undef;
4847 if (strEQ(d,"until")) return KEY_until;
4848 if (strEQ(d,"untie")) return KEY_untie;
4849 if (strEQ(d,"utime")) return -KEY_utime;
4850 if (strEQ(d,"umask")) return -KEY_umask;
4853 if (strEQ(d,"unless")) return KEY_unless;
4854 if (strEQ(d,"unpack")) return -KEY_unpack;
4855 if (strEQ(d,"unlink")) return -KEY_unlink;
4858 if (strEQ(d,"unshift")) return KEY_unshift;
4859 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4864 if (strEQ(d,"values")) return -KEY_values;
4865 if (strEQ(d,"vec")) return -KEY_vec;
4870 if (strEQ(d,"warn")) return -KEY_warn;
4871 if (strEQ(d,"wait")) return -KEY_wait;
4874 if (strEQ(d,"while")) return KEY_while;
4875 if (strEQ(d,"write")) return -KEY_write;
4878 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4881 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4886 if (len == 1) return -KEY_x;
4887 if (strEQ(d,"xor")) return -KEY_xor;
4890 if (len == 1) return KEY_y;
4899 checkcomma(register char *s, char *name, char *what)
4903 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4904 dTHR; /* only for ckWARN */
4905 if (ckWARN(WARN_SYNTAX)) {
4907 for (w = s+2; *w && level; w++) {
4914 for (; *w && isSPACE(*w); w++) ;
4915 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4916 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4919 while (s < PL_bufend && isSPACE(*s))
4923 while (s < PL_bufend && isSPACE(*s))
4925 if (isIDFIRST_lazy(s)) {
4927 while (isALNUM_lazy(s))
4929 while (s < PL_bufend && isSPACE(*s))
4934 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4938 croak("No comma allowed after %s", what);
4944 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4947 HV *table = GvHV(PL_hintgv); /* ^H */
4950 bool oldcatch = CATCH_GET;
4956 yyerror("%^H is not defined");
4959 cvp = hv_fetch(table, key, strlen(key), FALSE);
4960 if (!cvp || !SvOK(*cvp)) {
4961 sprintf(buf,"$^H{%s} is not defined", key);
4965 sv_2mortal(sv); /* Parent created it permanently */
4968 pv = sv_2mortal(newSVpv(s, len));
4970 typesv = sv_2mortal(newSVpv(type, 0));
4972 typesv = &PL_sv_undef;
4974 Zero(&myop, 1, BINOP);
4975 myop.op_last = (OP *) &myop;
4976 myop.op_next = Nullop;
4977 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4979 PUSHSTACKi(PERLSI_OVERLOAD);
4982 PL_op = (OP *) &myop;
4983 if (PERLDB_SUB && PL_curstash != PL_debstash)
4984 PL_op->op_private |= OPpENTERSUB_DB;
4995 if (PL_op = pp_entersub(ARGS))
5002 CATCH_SET(oldcatch);
5006 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5009 return SvREFCNT_inc(res);
5013 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5015 register char *d = dest;
5016 register char *e = d + destlen - 3; /* two-character token, ending NUL */
5019 croak(ident_too_long);
5020 if (isALNUM(*s)) /* UTF handled below */
5022 else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5027 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5031 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5032 char *t = s + UTF8SKIP(s);
5033 while (*t & 0x80 && is_utf8_mark((U8*)t))
5035 if (d + (t - s) > e)
5036 croak(ident_too_long);
5037 Copy(s, d, t - s, char);
5050 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5057 if (PL_lex_brackets == 0)
5058 PL_lex_fakebrack = 0;
5062 e = d + destlen - 3; /* two-character token, ending NUL */
5064 while (isDIGIT(*s)) {
5066 croak(ident_too_long);
5073 croak(ident_too_long);
5074 if (isALNUM(*s)) /* UTF handled below */
5076 else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5081 else if (*s == ':' && s[1] == ':') {
5085 else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5086 char *t = s + UTF8SKIP(s);
5087 while (*t & 0x80 && is_utf8_mark((U8*)t))
5089 if (d + (t - s) > e)
5090 croak(ident_too_long);
5091 Copy(s, d, t - s, char);
5102 if (PL_lex_state != LEX_NORMAL)
5103 PL_lex_state = LEX_INTERPENDMAYBE;
5106 if (*s == '$' && s[1] &&
5107 (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5120 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5125 if (isSPACE(s[-1])) {
5128 if (ch != ' ' && ch != '\t') {
5134 if (isIDFIRST_lazy(d)) {
5138 while (e < send && isALNUM_lazy(e) || *e == ':') {
5140 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5143 Copy(s, d, e - s, char);
5148 while (isALNUM(*s) || *s == ':')
5152 while (s < send && (*s == ' ' || *s == '\t')) s++;
5153 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5154 dTHR; /* only for ckWARN */
5155 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5156 char *brack = *s == '[' ? "[...]" : "{...}";
5157 warner(WARN_AMBIGUOUS,
5158 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5159 funny, dest, brack, funny, dest, brack);
5161 PL_lex_fakebrack = PL_lex_brackets+1;
5163 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5169 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5170 PL_lex_state = LEX_INTERPEND;
5173 if (PL_lex_state == LEX_NORMAL) {
5174 dTHR; /* only for ckWARN */
5175 if (ckWARN(WARN_AMBIGUOUS) &&
5176 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5178 warner(WARN_AMBIGUOUS,
5179 "Ambiguous use of %c{%s} resolved to %c%s",
5180 funny, dest, funny, dest);
5185 s = bracket; /* let the parser handle it */
5189 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5190 PL_lex_state = LEX_INTERPEND;
5194 void pmflag(U16 *pmfl, int ch)
5199 *pmfl |= PMf_GLOBAL;
5201 *pmfl |= PMf_CONTINUE;
5205 *pmfl |= PMf_MULTILINE;
5207 *pmfl |= PMf_SINGLELINE;
5209 *pmfl |= PMf_EXTENDED;
5213 scan_pat(char *start, I32 type)
5218 s = scan_str(start);
5221 SvREFCNT_dec(PL_lex_stuff);
5222 PL_lex_stuff = Nullsv;
5223 croak("Search pattern not terminated");
5226 pm = (PMOP*)newPMOP(type, 0);
5227 if (PL_multi_open == '?')
5228 pm->op_pmflags |= PMf_ONCE;
5230 while (*s && strchr("iomsx", *s))
5231 pmflag(&pm->op_pmflags,*s++);
5234 while (*s && strchr("iogcmsx", *s))
5235 pmflag(&pm->op_pmflags,*s++);
5237 pm->op_pmpermflags = pm->op_pmflags;
5239 PL_lex_op = (OP*)pm;
5240 yylval.ival = OP_MATCH;
5245 scan_subst(char *start)
5252 yylval.ival = OP_NULL;
5254 s = scan_str(start);
5258 SvREFCNT_dec(PL_lex_stuff);
5259 PL_lex_stuff = Nullsv;
5260 croak("Substitution pattern not terminated");
5263 if (s[-1] == PL_multi_open)
5266 first_start = PL_multi_start;
5270 SvREFCNT_dec(PL_lex_stuff);
5271 PL_lex_stuff = Nullsv;
5273 SvREFCNT_dec(PL_lex_repl);
5274 PL_lex_repl = Nullsv;
5275 croak("Substitution replacement not terminated");
5277 PL_multi_start = first_start; /* so whole substitution is taken together */
5279 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5285 else if (strchr("iogcmsx", *s))
5286 pmflag(&pm->op_pmflags,*s++);
5293 pm->op_pmflags |= PMf_EVAL;
5294 repl = newSVpv("",0);
5296 sv_catpv(repl, es ? "eval " : "do ");
5297 sv_catpvn(repl, "{ ", 2);
5298 sv_catsv(repl, PL_lex_repl);
5299 sv_catpvn(repl, " };", 2);
5300 SvCOMPILED_on(repl);
5301 SvREFCNT_dec(PL_lex_repl);
5305 pm->op_pmpermflags = pm->op_pmflags;
5306 PL_lex_op = (OP*)pm;
5307 yylval.ival = OP_SUBST;
5312 scan_trans(char *start)
5323 yylval.ival = OP_NULL;
5325 s = scan_str(start);
5328 SvREFCNT_dec(PL_lex_stuff);
5329 PL_lex_stuff = Nullsv;
5330 croak("Transliteration pattern not terminated");
5332 if (s[-1] == PL_multi_open)
5338 SvREFCNT_dec(PL_lex_stuff);
5339 PL_lex_stuff = Nullsv;
5341 SvREFCNT_dec(PL_lex_repl);
5342 PL_lex_repl = Nullsv;
5343 croak("Transliteration replacement not terminated");
5347 o = newSVOP(OP_TRANS, 0, 0);
5348 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5351 New(803,tbl,256,short);
5352 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5356 complement = del = squash = 0;
5357 while (strchr("cdsCU", *s)) {
5359 complement = OPpTRANS_COMPLEMENT;
5361 del = OPpTRANS_DELETE;
5363 squash = OPpTRANS_SQUASH;
5368 utf8 &= ~OPpTRANS_FROM_UTF;
5370 utf8 |= OPpTRANS_FROM_UTF;
5374 utf8 &= ~OPpTRANS_TO_UTF;
5376 utf8 |= OPpTRANS_TO_UTF;
5379 croak("Too many /C and /U options");
5384 o->op_private = del|squash|complement|utf8;
5387 yylval.ival = OP_TRANS;
5392 scan_heredoc(register char *s)
5396 I32 op_type = OP_SCALAR;
5403 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5407 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5410 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5411 if (*peek && strchr("`'\"",*peek)) {
5414 s = delimcpy(d, e, s, PL_bufend, term, &len);
5424 if (!isALNUM_lazy(s))
5425 deprecate("bare << to mean <<\"\"");
5426 for (; isALNUM_lazy(s); s++) {
5431 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5432 croak("Delimiter for here document is too long");
5435 len = d - PL_tokenbuf;
5436 #ifndef PERL_STRICT_CR
5437 d = strchr(s, '\r');
5441 while (s < PL_bufend) {
5447 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5456 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5461 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5462 herewas = newSVpv(s,PL_bufend-s);
5464 s--, herewas = newSVpv(s,d-s);
5465 s += SvCUR(herewas);
5467 tmpstr = NEWSV(87,79);
5468 sv_upgrade(tmpstr, SVt_PVIV);
5473 else if (term == '`') {
5474 op_type = OP_BACKTICK;
5475 SvIVX(tmpstr) = '\\';
5479 PL_multi_start = PL_curcop->cop_line;
5480 PL_multi_open = PL_multi_close = '<';
5481 term = *PL_tokenbuf;
5484 while (s < PL_bufend &&
5485 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5487 PL_curcop->cop_line++;
5489 if (s >= PL_bufend) {
5490 PL_curcop->cop_line = PL_multi_start;
5491 missingterm(PL_tokenbuf);
5493 sv_setpvn(tmpstr,d+1,s-d);
5495 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5497 sv_catpvn(herewas,s,PL_bufend-s);
5498 sv_setsv(PL_linestr,herewas);
5499 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5500 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5503 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5504 while (s >= PL_bufend) { /* multiple line string? */
5506 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5507 PL_curcop->cop_line = PL_multi_start;
5508 missingterm(PL_tokenbuf);
5510 PL_curcop->cop_line++;
5511 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5512 #ifndef PERL_STRICT_CR
5513 if (PL_bufend - PL_linestart >= 2) {
5514 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5515 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5517 PL_bufend[-2] = '\n';
5519 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5521 else if (PL_bufend[-1] == '\r')
5522 PL_bufend[-1] = '\n';
5524 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5525 PL_bufend[-1] = '\n';
5527 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5528 SV *sv = NEWSV(88,0);
5530 sv_upgrade(sv, SVt_PVMG);
5531 sv_setsv(sv,PL_linestr);
5532 av_store(GvAV(PL_curcop->cop_filegv),
5533 (I32)PL_curcop->cop_line,sv);
5535 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5538 sv_catsv(PL_linestr,herewas);
5539 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5543 sv_catsv(tmpstr,PL_linestr);
5546 PL_multi_end = PL_curcop->cop_line;
5548 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5549 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5550 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5552 SvREFCNT_dec(herewas);
5553 PL_lex_stuff = tmpstr;
5554 yylval.ival = op_type;
5559 takes: current position in input buffer
5560 returns: new position in input buffer
5561 side-effects: yylval and lex_op are set.
5566 <FH> read from filehandle
5567 <pkg::FH> read from package qualified filehandle
5568 <pkg'FH> read from package qualified filehandle
5569 <$fh> read from filehandle in $fh
5575 scan_inputsymbol(char *start)
5577 register char *s = start; /* current position in buffer */
5582 d = PL_tokenbuf; /* start of temp holding space */
5583 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5584 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5586 /* die if we didn't have space for the contents of the <>,
5590 if (len >= sizeof PL_tokenbuf)
5591 croak("Excessively long <> operator");
5593 croak("Unterminated <> operator");
5598 Remember, only scalar variables are interpreted as filehandles by
5599 this code. Anything more complex (e.g., <$fh{$num}>) will be
5600 treated as a glob() call.
5601 This code makes use of the fact that except for the $ at the front,
5602 a scalar variable and a filehandle look the same.
5604 if (*d == '$' && d[1]) d++;
5606 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5607 while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5610 /* If we've tried to read what we allow filehandles to look like, and
5611 there's still text left, then it must be a glob() and not a getline.
5612 Use scan_str to pull out the stuff between the <> and treat it
5613 as nothing more than a string.
5616 if (d - PL_tokenbuf != len) {
5617 yylval.ival = OP_GLOB;
5619 s = scan_str(start);
5621 croak("Glob not terminated");
5625 /* we're in a filehandle read situation */
5628 /* turn <> into <ARGV> */
5630 (void)strcpy(d,"ARGV");
5632 /* if <$fh>, create the ops to turn the variable into a
5638 /* try to find it in the pad for this block, otherwise find
5639 add symbol table ops
5641 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5642 OP *o = newOP(OP_PADSV, 0);
5644 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5647 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5648 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5649 newUNOP(OP_RV2GV, 0,
5650 newUNOP(OP_RV2SV, 0,
5651 newGVOP(OP_GV, 0, gv))));
5653 /* we created the ops in lex_op, so make yylval.ival a null op */
5654 yylval.ival = OP_NULL;
5657 /* If it's none of the above, it must be a literal filehandle
5658 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5660 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5661 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5662 yylval.ival = OP_NULL;
5671 takes: start position in buffer
5672 returns: position to continue reading from buffer
5673 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5674 updates the read buffer.
5676 This subroutine pulls a string out of the input. It is called for:
5677 q single quotes q(literal text)
5678 ' single quotes 'literal text'
5679 qq double quotes qq(interpolate $here please)
5680 " double quotes "interpolate $here please"
5681 qx backticks qx(/bin/ls -l)
5682 ` backticks `/bin/ls -l`
5683 qw quote words @EXPORT_OK = qw( func() $spam )
5684 m// regexp match m/this/
5685 s/// regexp substitute s/this/that/
5686 tr/// string transliterate tr/this/that/
5687 y/// string transliterate y/this/that/
5688 ($*@) sub prototypes sub foo ($)
5689 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5691 In most of these cases (all but <>, patterns and transliterate)
5692 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5693 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5694 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5697 It skips whitespace before the string starts, and treats the first
5698 character as the delimiter. If the delimiter is one of ([{< then
5699 the corresponding "close" character )]}> is used as the closing
5700 delimiter. It allows quoting of delimiters, and if the string has
5701 balanced delimiters ([{<>}]) it allows nesting.
5703 The lexer always reads these strings into lex_stuff, except in the
5704 case of the operators which take *two* arguments (s/// and tr///)
5705 when it checks to see if lex_stuff is full (presumably with the 1st
5706 arg to s or tr) and if so puts the string into lex_repl.
5711 scan_str(char *start)
5714 SV *sv; /* scalar value: string */
5715 char *tmps; /* temp string, used for delimiter matching */
5716 register char *s = start; /* current position in the buffer */
5717 register char term; /* terminating character */
5718 register char *to; /* current position in the sv's data */
5719 I32 brackets = 1; /* bracket nesting level */
5721 /* skip space before the delimiter */
5725 /* mark where we are, in case we need to report errors */
5728 /* after skipping whitespace, the next character is the terminator */
5730 /* mark where we are */
5731 PL_multi_start = PL_curcop->cop_line;
5732 PL_multi_open = term;
5734 /* find corresponding closing delimiter */
5735 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5737 PL_multi_close = term;
5739 /* create a new SV to hold the contents. 87 is leak category, I'm
5740 assuming. 79 is the SV's initial length. What a random number. */
5742 sv_upgrade(sv, SVt_PVIV);
5744 (void)SvPOK_only(sv); /* validate pointer */
5746 /* move past delimiter and try to read a complete string */
5749 /* extend sv if need be */
5750 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5751 /* set 'to' to the next character in the sv's string */
5752 to = SvPVX(sv)+SvCUR(sv);
5754 /* if open delimiter is the close delimiter read unbridle */
5755 if (PL_multi_open == PL_multi_close) {
5756 for (; s < PL_bufend; s++,to++) {
5757 /* embedded newlines increment the current line number */
5758 if (*s == '\n' && !PL_rsfp)
5759 PL_curcop->cop_line++;
5760 /* handle quoted delimiters */
5761 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5764 /* any other quotes are simply copied straight through */
5768 /* terminate when run out of buffer (the for() condition), or
5769 have found the terminator */
5770 else if (*s == term)
5776 /* if the terminator isn't the same as the start character (e.g.,
5777 matched brackets), we have to allow more in the quoting, and
5778 be prepared for nested brackets.
5781 /* read until we run out of string, or we find the terminator */
5782 for (; s < PL_bufend; s++,to++) {
5783 /* embedded newlines increment the line count */
5784 if (*s == '\n' && !PL_rsfp)
5785 PL_curcop->cop_line++;
5786 /* backslashes can escape the open or closing characters */
5787 if (*s == '\\' && s+1 < PL_bufend) {
5788 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5793 /* allow nested opens and closes */
5794 else if (*s == PL_multi_close && --brackets <= 0)
5796 else if (*s == PL_multi_open)
5801 /* terminate the copied string and update the sv's end-of-string */
5803 SvCUR_set(sv, to - SvPVX(sv));
5806 * this next chunk reads more into the buffer if we're not done yet
5809 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5811 #ifndef PERL_STRICT_CR
5812 if (to - SvPVX(sv) >= 2) {
5813 if ((to[-2] == '\r' && to[-1] == '\n') ||
5814 (to[-2] == '\n' && to[-1] == '\r'))
5818 SvCUR_set(sv, to - SvPVX(sv));
5820 else if (to[-1] == '\r')
5823 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5827 /* if we're out of file, or a read fails, bail and reset the current
5828 line marker so we can report where the unterminated string began
5831 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5833 PL_curcop->cop_line = PL_multi_start;
5836 /* we read a line, so increment our line counter */
5837 PL_curcop->cop_line++;
5839 /* update debugger info */
5840 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5841 SV *sv = NEWSV(88,0);
5843 sv_upgrade(sv, SVt_PVMG);
5844 sv_setsv(sv,PL_linestr);
5845 av_store(GvAV(PL_curcop->cop_filegv),
5846 (I32)PL_curcop->cop_line, sv);
5849 /* having changed the buffer, we must update PL_bufend */
5850 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5853 /* at this point, we have successfully read the delimited string */
5855 PL_multi_end = PL_curcop->cop_line;
5858 /* if we allocated too much space, give some back */
5859 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5860 SvLEN_set(sv, SvCUR(sv) + 1);
5861 Renew(SvPVX(sv), SvLEN(sv), char);
5864 /* decide whether this is the first or second quoted string we've read
5877 takes: pointer to position in buffer
5878 returns: pointer to new position in buffer
5879 side-effects: builds ops for the constant in yylval.op
5881 Read a number in any of the formats that Perl accepts:
5883 0(x[0-7A-F]+)|([0-7]+)
5884 [\d_]+(\.[\d_]*)?[Ee](\d+)
5886 Underbars (_) are allowed in decimal numbers. If -w is on,
5887 underbars before a decimal point must be at three digit intervals.
5889 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5892 If it reads a number without a decimal point or an exponent, it will
5893 try converting the number to an integer and see if it can do so
5894 without loss of precision.
5898 scan_num(char *start)
5900 register char *s = start; /* current position in buffer */
5901 register char *d; /* destination in temp buffer */
5902 register char *e; /* end of temp buffer */
5903 I32 tryiv; /* used to see if it can be an int */
5904 double value; /* number read, as a double */
5905 SV *sv; /* place to put the converted number */
5906 I32 floatit; /* boolean: int or float? */
5907 char *lastub = 0; /* position of last underbar */
5908 static char number_too_long[] = "Number too long";
5910 /* We use the first character to decide what type of number this is */
5914 croak("panic: scan_num");
5916 /* if it starts with a 0, it could be an octal number, a decimal in
5917 0.13 disguise, or a hexadecimal number.
5922 u holds the "number so far"
5923 shift the power of 2 of the base (hex == 4, octal == 3)
5924 overflowed was the number more than we can hold?
5926 Shift is used when we add a digit. It also serves as an "are
5927 we in octal or hex?" indicator to disallow hex characters when
5932 bool overflowed = FALSE;
5939 /* check for a decimal in disguise */
5940 else if (s[1] == '.')
5942 /* so it must be octal */
5947 /* read the rest of the octal number */
5949 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5953 /* if we don't mention it, we're done */
5962 /* 8 and 9 are not octal */
5965 yyerror("Illegal octal digit");
5969 case '0': case '1': case '2': case '3': case '4':
5970 case '5': case '6': case '7':
5971 b = *s++ & 15; /* ASCII digit -> value of digit */
5975 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5976 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5977 /* make sure they said 0x */
5982 /* Prepare to put the digit we have onto the end
5983 of the number so far. We check for overflows.
5987 n = u << shift; /* make room for the digit */
5988 if (!overflowed && (n >> shift) != u
5989 && !(PL_hints & HINT_NEW_BINARY)) {
5990 warn("Integer overflow in %s number",
5991 (shift == 4) ? "hex" : "octal");
5994 u = n | b; /* add the digit to the end */
5999 /* if we get here, we had success: make a scalar value from
6005 if ( PL_hints & HINT_NEW_BINARY)
6006 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6011 handle decimal numbers.
6012 we're also sent here when we read a 0 as the first digit
6014 case '1': case '2': case '3': case '4': case '5':
6015 case '6': case '7': case '8': case '9': case '.':
6018 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6021 /* read next group of digits and _ and copy into d */
6022 while (isDIGIT(*s) || *s == '_') {
6023 /* skip underscores, checking for misplaced ones
6027 dTHR; /* only for ckWARN */
6028 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6029 warner(WARN_SYNTAX, "Misplaced _ in number");
6033 /* check for end of fixed-length buffer */
6035 croak(number_too_long);
6036 /* if we're ok, copy the character */
6041 /* final misplaced underbar check */
6042 if (lastub && s - lastub != 3) {
6044 if (ckWARN(WARN_SYNTAX))
6045 warner(WARN_SYNTAX, "Misplaced _ in number");
6048 /* read a decimal portion if there is one. avoid
6049 3..5 being interpreted as the number 3. followed
6052 if (*s == '.' && s[1] != '.') {
6056 /* copy, ignoring underbars, until we run out of
6057 digits. Note: no misplaced underbar checks!
6059 for (; isDIGIT(*s) || *s == '_'; s++) {
6060 /* fixed length buffer check */
6062 croak(number_too_long);
6068 /* read exponent part, if present */
6069 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6073 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6074 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6076 /* allow positive or negative exponent */
6077 if (*s == '+' || *s == '-')
6080 /* read digits of exponent (no underbars :-) */
6081 while (isDIGIT(*s)) {
6083 croak(number_too_long);
6088 /* terminate the string */
6091 /* make an sv from the string */
6093 /* reset numeric locale in case we were earlier left in Swaziland */
6094 SET_NUMERIC_STANDARD();
6095 value = atof(PL_tokenbuf);
6098 See if we can make do with an integer value without loss of
6099 precision. We use I_V to cast to an int, because some
6100 compilers have issues. Then we try casting it back and see
6101 if it was the same. We only do this if we know we
6102 specifically read an integer.
6104 Note: if floatit is true, then we don't need to do the
6108 if (!floatit && (double)tryiv == value)
6109 sv_setiv(sv, tryiv);
6111 sv_setnv(sv, value);
6112 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6113 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6114 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6118 /* make the op for the constant and return */
6120 yylval.opval = newSVOP(OP_CONST, 0, sv);
6126 scan_formline(register char *s)
6131 SV *stuff = newSVpv("",0);
6132 bool needargs = FALSE;
6135 if (*s == '.' || *s == '}') {
6137 #ifdef PERL_STRICT_CR
6138 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6140 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6145 if (PL_in_eval && !PL_rsfp) {
6146 eol = strchr(s,'\n');
6151 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6153 for (t = s; t < eol; t++) {
6154 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6156 goto enough; /* ~~ must be first line in formline */
6158 if (*t == '@' || *t == '^')
6161 sv_catpvn(stuff, s, eol-s);
6165 s = filter_gets(PL_linestr, PL_rsfp, 0);
6166 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6167 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6170 yyerror("Format not terminated");
6180 PL_lex_state = LEX_NORMAL;
6181 PL_nextval[PL_nexttoke].ival = 0;
6185 PL_lex_state = LEX_FORMLINE;
6186 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6188 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6192 SvREFCNT_dec(stuff);
6193 PL_lex_formbrack = 0;
6204 PL_cshlen = strlen(PL_cshname);
6209 start_subparse(I32 is_format, U32 flags)
6212 I32 oldsavestack_ix = PL_savestack_ix;
6213 CV* outsidecv = PL_compcv;
6217 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6219 save_I32(&PL_subline);
6220 save_item(PL_subname);
6222 SAVESPTR(PL_curpad);
6223 SAVESPTR(PL_comppad);
6224 SAVESPTR(PL_comppad_name);
6225 SAVESPTR(PL_compcv);
6226 SAVEI32(PL_comppad_name_fill);
6227 SAVEI32(PL_min_intro_pending);
6228 SAVEI32(PL_max_intro_pending);
6229 SAVEI32(PL_pad_reset_pending);
6231 PL_compcv = (CV*)NEWSV(1104,0);
6232 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6233 CvFLAGS(PL_compcv) |= flags;
6235 PL_comppad = newAV();
6236 av_push(PL_comppad, Nullsv);
6237 PL_curpad = AvARRAY(PL_comppad);
6238 PL_comppad_name = newAV();
6239 PL_comppad_name_fill = 0;
6240 PL_min_intro_pending = 0;
6242 PL_subline = PL_curcop->cop_line;
6244 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6245 PL_curpad[0] = (SV*)newAV();
6246 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6247 #endif /* USE_THREADS */
6249 comppadlist = newAV();
6250 AvREAL_off(comppadlist);
6251 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6252 av_store(comppadlist, 1, (SV*)PL_comppad);
6254 CvPADLIST(PL_compcv) = comppadlist;
6255 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6257 CvOWNER(PL_compcv) = 0;
6258 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6259 MUTEX_INIT(CvMUTEXP(PL_compcv));
6260 #endif /* USE_THREADS */
6262 return oldsavestack_ix;
6281 char *context = NULL;
6285 if (!yychar || (yychar == ';' && !PL_rsfp))
6287 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6288 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6289 while (isSPACE(*PL_oldoldbufptr))
6291 context = PL_oldoldbufptr;
6292 contlen = PL_bufptr - PL_oldoldbufptr;
6294 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6295 PL_oldbufptr != PL_bufptr) {
6296 while (isSPACE(*PL_oldbufptr))
6298 context = PL_oldbufptr;
6299 contlen = PL_bufptr - PL_oldbufptr;
6301 else if (yychar > 255)
6302 where = "next token ???";
6303 else if ((yychar & 127) == 127) {
6304 if (PL_lex_state == LEX_NORMAL ||
6305 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6306 where = "at end of line";
6307 else if (PL_lex_inpat)
6308 where = "within pattern";
6310 where = "within string";
6313 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6315 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6316 else if (isPRINT_LC(yychar))
6317 sv_catpvf(where_sv, "%c", yychar);
6319 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6320 where = SvPVX(where_sv);
6322 msg = sv_2mortal(newSVpv(s, 0));
6323 sv_catpvf(msg, " at %_ line %ld, ",
6324 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6326 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6328 sv_catpvf(msg, "%s\n", where);
6329 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6331 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6332 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6337 else if (PL_in_eval)
6338 sv_catsv(ERRSV, msg);
6340 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6341 if (++PL_error_count >= 10)
6342 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6344 PL_in_my_stash = Nullhv;