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 /* The following are arranged oddly so that the guard on the switch statement
66 * can get by with a single comparison (if the compiler is smart enough).
69 /* #define LEX_NOTPARSING 11 is done in perl.h. */
72 #define LEX_INTERPNORMAL 9
73 #define LEX_INTERPCASEMOD 8
74 #define LEX_INTERPPUSH 7
75 #define LEX_INTERPSTART 6
76 #define LEX_INTERPEND 5
77 #define LEX_INTERPENDMAYBE 4
78 #define LEX_INTERPCONCAT 3
79 #define LEX_INTERPCONST 2
80 #define LEX_FORMLINE 1
81 #define LEX_KNOWNEXT 0
90 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
92 # include <unistd.h> /* Needed for execv() */
100 #include "keywords.h"
105 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
107 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
108 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
109 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
110 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
111 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
112 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
113 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
114 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
115 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
116 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
117 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
118 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
119 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
120 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
121 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
122 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
123 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
124 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
125 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
126 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
128 /* This bit of chicanery makes a unary function followed by
129 * a parenthesis into a function with one argument, highest precedence.
131 #define UNI(f) return(yylval.ival = f, \
134 PL_last_uni = PL_oldbufptr, \
135 PL_last_lop_op = f, \
136 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
138 #define UNIBRACK(f) return(yylval.ival = f, \
140 PL_last_uni = PL_oldbufptr, \
141 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
143 /* grandfather return to old style */
144 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
149 if (*PL_bufptr == '=') {
151 if (toketype == ANDAND)
152 yylval.ival = OP_ANDASSIGN;
153 else if (toketype == OROR)
154 yylval.ival = OP_ORASSIGN;
161 no_op(char *what, char *s)
163 char *oldbp = PL_bufptr;
164 bool is_first = (PL_oldbufptr == PL_linestart);
167 yywarn(form("%s found where operator expected", what));
169 warn("\t(Missing semicolon on previous line?)\n");
170 else if (PL_oldoldbufptr && isIDFIRST(*PL_oldoldbufptr)) {
172 for (t = PL_oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
173 if (t < PL_bufptr && isSPACE(*t))
174 warn("\t(Do you need to predeclare %.*s?)\n",
175 t - PL_oldoldbufptr, PL_oldoldbufptr);
179 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
189 char *nl = strrchr(s,'\n');
195 iscntrl(PL_multi_close)
197 PL_multi_close < 32 || PL_multi_close == 127
201 tmpbuf[1] = toCTRL(PL_multi_close);
207 *tmpbuf = PL_multi_close;
211 q = strchr(s,'"') ? '\'' : '"';
212 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
219 if (ckWARN(WARN_DEPRECATED))
220 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
226 deprecate("comma-less variable list");
232 win32_textfilter(int idx, SV *sv, int maxlen)
234 I32 count = FILTER_READ(idx+1, sv, maxlen);
235 if (count > 0 && !maxlen)
236 win32_strip_return(sv);
244 utf16_textfilter(int idx, SV *sv, int maxlen)
246 I32 count = FILTER_READ(idx+1, sv, maxlen);
250 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
251 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
252 sv_usepvn(sv, (char*)tmps, tend - tmps);
259 utf16rev_textfilter(int idx, SV *sv, int maxlen)
261 I32 count = FILTER_READ(idx+1, sv, maxlen);
265 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
266 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
267 sv_usepvn(sv, (char*)tmps, tend - tmps);
282 SAVEI32(PL_lex_dojoin);
283 SAVEI32(PL_lex_brackets);
284 SAVEI32(PL_lex_fakebrack);
285 SAVEI32(PL_lex_casemods);
286 SAVEI32(PL_lex_starts);
287 SAVEI32(PL_lex_state);
288 SAVESPTR(PL_lex_inpat);
289 SAVEI32(PL_lex_inwhat);
290 SAVEI16(PL_curcop->cop_line);
293 SAVEPPTR(PL_oldbufptr);
294 SAVEPPTR(PL_oldoldbufptr);
295 SAVEPPTR(PL_linestart);
296 SAVESPTR(PL_linestr);
297 SAVEPPTR(PL_lex_brackstack);
298 SAVEPPTR(PL_lex_casestack);
299 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
300 SAVESPTR(PL_lex_stuff);
301 SAVEI32(PL_lex_defer);
302 SAVESPTR(PL_lex_repl);
303 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
304 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
306 PL_lex_state = LEX_NORMAL;
310 PL_lex_fakebrack = 0;
311 New(899, PL_lex_brackstack, 120, char);
312 New(899, PL_lex_casestack, 12, char);
313 SAVEFREEPV(PL_lex_brackstack);
314 SAVEFREEPV(PL_lex_casestack);
316 *PL_lex_casestack = '\0';
319 PL_lex_stuff = Nullsv;
320 PL_lex_repl = Nullsv;
324 if (SvREADONLY(PL_linestr))
325 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
326 s = SvPV(PL_linestr, len);
327 if (len && s[len-1] != ';') {
328 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
329 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
330 sv_catpvn(PL_linestr, "\n;", 2);
332 SvTEMP_off(PL_linestr);
333 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
334 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
336 PL_rs = newSVpv("\n", 1);
343 PL_doextract = FALSE;
347 restore_rsfp(void *f)
349 PerlIO *fp = (PerlIO*)f;
351 if (PL_rsfp == PerlIO_stdin())
352 PerlIO_clearerr(PL_rsfp);
353 else if (PL_rsfp && (PL_rsfp != fp))
354 PerlIO_close(PL_rsfp);
359 restore_expect(void *e)
361 /* a safe way to store a small integer in a pointer */
362 PL_expect = (expectation)((char *)e - PL_tokenbuf);
366 restore_lex_expect(void *e)
368 /* a safe way to store a small integer in a pointer */
369 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
381 PL_curcop->cop_line++;
384 while (*s == ' ' || *s == '\t') s++;
385 if (strnEQ(s, "line ", 5)) {
394 while (*s == ' ' || *s == '\t')
396 if (*s == '"' && (t = strchr(s+1, '"')))
400 return; /* false alarm */
401 for (t = s; !isSPACE(*t); t++) ;
406 PL_curcop->cop_filegv = gv_fetchfile(s);
408 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
410 PL_curcop->cop_line = atoi(n)-1;
414 skipspace(register char *s)
417 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
418 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
424 while (s < PL_bufend && isSPACE(*s))
426 if (s < PL_bufend && *s == '#') {
427 while (s < PL_bufend && *s != '\n')
432 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
434 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
435 if (PL_minus_n || PL_minus_p) {
436 sv_setpv(PL_linestr,PL_minus_p ?
437 ";}continue{print or die qq(-p destination: $!\\n)" :
439 sv_catpv(PL_linestr,";}");
440 PL_minus_n = PL_minus_p = 0;
443 sv_setpv(PL_linestr,";");
444 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
445 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
446 if (PL_preprocess && !PL_in_eval)
447 (void)PerlProc_pclose(PL_rsfp);
448 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
449 PerlIO_clearerr(PL_rsfp);
451 (void)PerlIO_close(PL_rsfp);
455 PL_linestart = PL_bufptr = s + prevlen;
456 PL_bufend = s + SvCUR(PL_linestr);
459 if (PERLDB_LINE && PL_curstash != PL_debstash) {
460 SV *sv = NEWSV(85,0);
462 sv_upgrade(sv, SVt_PVMG);
463 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
464 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
475 if (PL_oldoldbufptr != PL_last_uni)
477 while (isSPACE(*PL_last_uni))
479 for (s = PL_last_uni; isALNUM(*s) || *s == '-'; s++) ;
480 if ((t = strchr(s, '(')) && t < PL_bufptr)
484 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
491 #define UNI(f) return uni(f,s)
499 PL_last_uni = PL_oldbufptr;
510 #endif /* CRIPPLED_CC */
512 #define LOP(f,x) return lop(f,x,s)
515 lop(I32 f, expectation x, char *s)
522 PL_last_lop = PL_oldbufptr;
538 PL_nexttype[PL_nexttoke] = type;
540 if (PL_lex_state != LEX_KNOWNEXT) {
541 PL_lex_defer = PL_lex_state;
542 PL_lex_expect = PL_expect;
543 PL_lex_state = LEX_KNOWNEXT;
548 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
553 start = skipspace(start);
556 (allow_pack && *s == ':') ||
557 (allow_initial_tick && *s == '\'') )
559 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
560 if (check_keyword && keyword(PL_tokenbuf, len))
562 if (token == METHOD) {
567 PL_expect = XOPERATOR;
572 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
573 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
580 force_ident(register char *s, int kind)
583 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
584 PL_nextval[PL_nexttoke].opval = o;
587 dTHR; /* just for in_eval */
588 o->op_private = OPpCONST_ENTERED;
589 /* XXX see note in pp_entereval() for why we forgo typo
590 warnings if the symbol must be introduced in an eval.
592 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
593 kind == '$' ? SVt_PV :
594 kind == '@' ? SVt_PVAV :
595 kind == '%' ? SVt_PVHV :
603 force_version(char *s)
605 OP *version = Nullop;
609 /* default VERSION number -- GBARR */
614 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
615 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
617 /* real VERSION number -- GBARR */
618 version = yylval.opval;
622 /* NOTE: The parser sees the package name and the VERSION swapped */
623 PL_nextval[PL_nexttoke].opval = version;
641 s = SvPV_force(sv, len);
645 while (s < send && *s != '\\')
650 if ( PL_hints & HINT_NEW_STRING )
651 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
654 if (s + 1 < send && (s[1] == '\\'))
655 s++; /* all that, just for this */
660 SvCUR_set(sv, d - SvPVX(sv));
662 if ( PL_hints & HINT_NEW_STRING )
663 return new_constant(NULL, 0, "q", sv, pv, "q");
670 register I32 op_type = yylval.ival;
672 if (op_type == OP_NULL) {
673 yylval.opval = PL_lex_op;
677 if (op_type == OP_CONST || op_type == OP_READLINE) {
678 SV *sv = tokeq(PL_lex_stuff);
680 if (SvTYPE(sv) == SVt_PVIV) {
681 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
687 nsv = newSVpv(p, len);
691 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
692 PL_lex_stuff = Nullsv;
696 PL_sublex_info.super_state = PL_lex_state;
697 PL_sublex_info.sub_inwhat = op_type;
698 PL_sublex_info.sub_op = PL_lex_op;
699 PL_lex_state = LEX_INTERPPUSH;
703 yylval.opval = PL_lex_op;
717 PL_lex_state = PL_sublex_info.super_state;
718 SAVEI32(PL_lex_dojoin);
719 SAVEI32(PL_lex_brackets);
720 SAVEI32(PL_lex_fakebrack);
721 SAVEI32(PL_lex_casemods);
722 SAVEI32(PL_lex_starts);
723 SAVEI32(PL_lex_state);
724 SAVESPTR(PL_lex_inpat);
725 SAVEI32(PL_lex_inwhat);
726 SAVEI16(PL_curcop->cop_line);
728 SAVEPPTR(PL_oldbufptr);
729 SAVEPPTR(PL_oldoldbufptr);
730 SAVEPPTR(PL_linestart);
731 SAVESPTR(PL_linestr);
732 SAVEPPTR(PL_lex_brackstack);
733 SAVEPPTR(PL_lex_casestack);
735 PL_linestr = PL_lex_stuff;
736 PL_lex_stuff = Nullsv;
738 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
739 PL_bufend += SvCUR(PL_linestr);
740 SAVEFREESV(PL_linestr);
742 PL_lex_dojoin = FALSE;
744 PL_lex_fakebrack = 0;
745 New(899, PL_lex_brackstack, 120, char);
746 New(899, PL_lex_casestack, 12, char);
747 SAVEFREEPV(PL_lex_brackstack);
748 SAVEFREEPV(PL_lex_casestack);
750 *PL_lex_casestack = '\0';
752 PL_lex_state = LEX_INTERPCONCAT;
753 PL_curcop->cop_line = PL_multi_start;
755 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
756 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
757 PL_lex_inpat = PL_sublex_info.sub_op;
759 PL_lex_inpat = Nullop;
767 if (!PL_lex_starts++) {
768 PL_expect = XOPERATOR;
769 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
773 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
774 PL_lex_state = LEX_INTERPCASEMOD;
778 /* Is there a right-hand side to take care of? */
779 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
780 PL_linestr = PL_lex_repl;
782 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
783 PL_bufend += SvCUR(PL_linestr);
784 SAVEFREESV(PL_linestr);
785 PL_lex_dojoin = FALSE;
787 PL_lex_fakebrack = 0;
789 *PL_lex_casestack = '\0';
791 if (SvCOMPILED(PL_lex_repl)) {
792 PL_lex_state = LEX_INTERPNORMAL;
796 PL_lex_state = LEX_INTERPCONCAT;
797 PL_lex_repl = Nullsv;
802 PL_bufend = SvPVX(PL_linestr);
803 PL_bufend += SvCUR(PL_linestr);
804 PL_expect = XOPERATOR;
812 Extracts a pattern, double-quoted string, or transliteration. This
815 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
816 processing a pattern (PL_lex_inpat is true), a transliteration
817 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
819 Returns a pointer to the character scanned up to. Iff this is
820 advanced from the start pointer supplied (ie if anything was
821 successfully parsed), will leave an OP for the substring scanned
822 in yylval. Caller must intuit reason for not parsing further
823 by looking at the next characters herself.
827 double-quoted style: \r and \n
828 regexp special ones: \D \s
830 backrefs: \1 (deprecated in substitution replacements)
831 case and quoting: \U \Q \E
832 stops on @ and $, but not for $ as tail anchor
835 characters are VERY literal, except for - not at the start or end
836 of the string, which indicates a range. scan_const expands the
837 range to the full set of intermediate characters.
839 In double-quoted strings:
841 double-quoted style: \r and \n
843 backrefs: \1 (deprecated)
844 case and quoting: \U \Q \E
847 scan_const does *not* construct ops to handle interpolated strings.
848 It stops processing as soon as it finds an embedded $ or @ variable
849 and leaves it to the caller to work out what's going on.
851 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
853 $ in pattern could be $foo or could be tail anchor. Assumption:
854 it's a tail anchor if $ is the last thing in the string, or if it's
855 followed by one of ")| \n\t"
857 \1 (backreferences) are turned into $1
859 The structure of the code is
860 while (there's a character to process) {
861 handle transliteration ranges
863 skip # initiated comments in //x patterns
864 check for embedded @foo
865 check for embedded scalars
867 leave intact backslashes from leave (below)
868 deprecate \1 in strings and sub replacements
869 handle string-changing backslashes \l \U \Q \E, etc.
870 switch (what was escaped) {
871 handle - in a transliteration (becomes a literal -)
872 handle \132 octal characters
873 handle 0x15 hex characters
874 handle \cV (control V)
875 handle printf backslashes (\f, \r, \n, etc)
878 } (end while character to read)
883 scan_const(char *start)
885 register char *send = PL_bufend; /* end of the constant */
886 SV *sv = NEWSV(93, send - start); /* sv for the constant */
887 register char *s = start; /* start of the constant */
888 register char *d = SvPVX(sv); /* destination for copies */
889 bool dorange = FALSE; /* are we in a translit range? */
891 I32 utf = PL_lex_inwhat == OP_TRANS
892 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
894 I32 thisutf = PL_lex_inwhat == OP_TRANS
895 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
898 /* leaveit is the set of acceptably-backslashed characters */
901 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
904 while (s < send || dorange) {
905 /* get transliterations out of the way (they're most literal) */
906 if (PL_lex_inwhat == OP_TRANS) {
907 /* expand a range A-Z to the full set of characters. AIE! */
909 I32 i; /* current expanded character */
910 I32 min; /* first character in range */
911 I32 max; /* last character in range */
913 i = d - SvPVX(sv); /* remember current offset */
914 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
915 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
916 d -= 2; /* eat the first char and the - */
918 min = (U8)*d; /* first char in range */
919 max = (U8)d[1]; /* last char in range */
922 if ((isLOWER(min) && isLOWER(max)) ||
923 (isUPPER(min) && isUPPER(max))) {
925 for (i = min; i <= max; i++)
929 for (i = min; i <= max; i++)
936 for (i = min; i <= max; i++)
939 /* mark the range as done, and continue */
944 /* range begins (ignore - as first or last char) */
945 else if (*s == '-' && s+1 < send && s != start) {
947 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
956 /* if we get here, we're not doing a transliteration */
958 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
959 except for the last char, which will be done separately. */
960 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
962 while (s < send && *s != ')')
964 } else if (s[2] == '{'
965 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
967 char *regparse = s + (s[2] == '{' ? 3 : 4);
970 while (count && (c = *regparse)) {
971 if (c == '\\' && regparse[1])
979 if (*regparse != ')') {
980 regparse--; /* Leave one char for continuation. */
981 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
988 /* likewise skip #-initiated comments in //x patterns */
989 else if (*s == '#' && PL_lex_inpat &&
990 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
991 while (s+1 < send && *s != '\n')
995 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
996 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
999 /* check for embedded scalars. only stop if we're sure it's a
1002 else if (*s == '$') {
1003 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1005 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1006 break; /* in regexp, $ might be tail anchor */
1009 /* (now in tr/// code again) */
1011 if (*s & 0x80 && thisutf) {
1012 dTHR; /* only for ckWARN */
1013 if (ckWARN(WARN_UTF8)) {
1014 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1024 if (*s == '\\' && s+1 < send) {
1027 /* some backslashes we leave behind */
1028 if (*s && strchr(leaveit, *s)) {
1034 /* deprecate \1 in strings and substitution replacements */
1035 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1036 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1038 dTHR; /* only for ckWARN */
1039 if (ckWARN(WARN_SYNTAX))
1040 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1045 /* string-change backslash escapes */
1046 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1051 /* if we get here, it's either a quoted -, or a digit */
1054 /* quoted - in transliterations */
1056 if (PL_lex_inwhat == OP_TRANS) {
1061 /* default action is to copy the quoted character */
1066 /* \132 indicates an octal constant */
1067 case '0': case '1': case '2': case '3':
1068 case '4': case '5': case '6': case '7':
1069 *d++ = scan_oct(s, 3, &len);
1073 /* \x24 indicates a hex constant */
1077 char* e = strchr(s, '}');
1080 yyerror("Missing right brace on \\x{}");
1083 if (ckWARN(WARN_UTF8))
1085 "Use of \\x{} without utf8 declaration");
1087 /* note: utf always shorter than hex */
1088 d = (char*)uv_to_utf8((U8*)d,
1089 scan_hex(s + 1, e - s - 1, &len));
1094 UV uv = (UV)scan_hex(s, 2, &len);
1095 if (utf && PL_lex_inwhat == OP_TRANS &&
1096 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1098 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1101 if (uv >= 127 && UTF) {
1103 if (ckWARN(WARN_UTF8))
1105 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1114 /* \c is a control character */
1128 /* printf-style backslashes, formfeeds, newlines, etc */
1154 } /* end if (backslash) */
1157 } /* while loop to process each character */
1159 /* terminate the string and set up the sv */
1161 SvCUR_set(sv, d - SvPVX(sv));
1164 /* shrink the sv if we allocated more than we used */
1165 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1166 SvLEN_set(sv, SvCUR(sv) + 1);
1167 Renew(SvPVX(sv), SvLEN(sv), char);
1170 /* return the substring (via yylval) only if we parsed anything */
1171 if (s > PL_bufptr) {
1172 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1173 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1175 ( PL_lex_inwhat == OP_TRANS
1177 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1180 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1186 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1188 intuit_more(register char *s)
1190 if (PL_lex_brackets)
1192 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1194 if (*s != '{' && *s != '[')
1199 /* In a pattern, so maybe we have {n,m}. */
1216 /* On the other hand, maybe we have a character class */
1219 if (*s == ']' || *s == '^')
1222 int weight = 2; /* let's weigh the evidence */
1224 unsigned char un_char = 255, last_un_char;
1225 char *send = strchr(s,']');
1226 char tmpbuf[sizeof PL_tokenbuf * 4];
1228 if (!send) /* has to be an expression */
1231 Zero(seen,256,char);
1234 else if (isDIGIT(*s)) {
1236 if (isDIGIT(s[1]) && s[2] == ']')
1242 for (; s < send; s++) {
1243 last_un_char = un_char;
1244 un_char = (unsigned char)*s;
1249 weight -= seen[un_char] * 10;
1250 if (isALNUM(s[1])) {
1251 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1252 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1257 else if (*s == '$' && s[1] &&
1258 strchr("[#!%*<>()-=",s[1])) {
1259 if (/*{*/ strchr("])} =",s[2]))
1268 if (strchr("wds]",s[1]))
1270 else if (seen['\''] || seen['"'])
1272 else if (strchr("rnftbxcav",s[1]))
1274 else if (isDIGIT(s[1])) {
1276 while (s[1] && isDIGIT(s[1]))
1286 if (strchr("aA01! ",last_un_char))
1288 if (strchr("zZ79~",s[1]))
1290 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1291 weight -= 5; /* cope with negative subscript */
1294 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1295 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1300 if (keyword(tmpbuf, d - tmpbuf))
1303 if (un_char == last_un_char + 1)
1305 weight -= seen[un_char];
1310 if (weight >= 0) /* probably a character class */
1318 intuit_method(char *start, GV *gv)
1320 char *s = start + (*start == '$');
1321 char tmpbuf[sizeof PL_tokenbuf];
1329 if ((cv = GvCVu(gv))) {
1330 char *proto = SvPVX(cv);
1340 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1341 if (*start == '$') {
1342 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1347 return *s == '(' ? FUNCMETH : METHOD;
1349 if (!keyword(tmpbuf, len)) {
1350 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1355 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1356 if (indirgv && GvCVu(indirgv))
1358 /* filehandle or package name makes it a method */
1359 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1361 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1362 return 0; /* no assumptions -- "=>" quotes bearword */
1364 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1366 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1370 return *s == '(' ? FUNCMETH : METHOD;
1380 char *pdb = PerlEnv_getenv("PERL5DB");
1384 SETERRNO(0,SS$_NORMAL);
1385 return "BEGIN { require 'perl5db.pl' }";
1391 /* Encoded script support. filter_add() effectively inserts a
1392 * 'pre-processing' function into the current source input stream.
1393 * Note that the filter function only applies to the current source file
1394 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1396 * The datasv parameter (which may be NULL) can be used to pass
1397 * private data to this instance of the filter. The filter function
1398 * can recover the SV using the FILTER_DATA macro and use it to
1399 * store private buffers and state information.
1401 * The supplied datasv parameter is upgraded to a PVIO type
1402 * and the IoDIRP field is used to store the function pointer.
1403 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1404 * private use must be set using malloc'd pointers.
1406 static int filter_debug = 0;
1409 filter_add(filter_t funcp, SV *datasv)
1411 if (!funcp){ /* temporary handy debugging hack to be deleted */
1412 filter_debug = atoi((char*)datasv);
1415 if (!PL_rsfp_filters)
1416 PL_rsfp_filters = newAV();
1418 datasv = NEWSV(255,0);
1419 if (!SvUPGRADE(datasv, SVt_PVIO))
1420 die("Can't upgrade filter_add data to SVt_PVIO");
1421 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1423 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1424 av_unshift(PL_rsfp_filters, 1);
1425 av_store(PL_rsfp_filters, 0, datasv) ;
1430 /* Delete most recently added instance of this filter function. */
1432 filter_del(filter_t funcp)
1435 warn("filter_del func %p", funcp);
1436 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1438 /* if filter is on top of stack (usual case) just pop it off */
1439 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1440 sv_free(av_pop(PL_rsfp_filters));
1444 /* we need to search for the correct entry and clear it */
1445 die("filter_del can only delete in reverse order (currently)");
1449 /* Invoke the n'th filter function for the current rsfp. */
1451 filter_read(int idx, SV *buf_sv, int maxlen)
1454 /* 0 = read one text line */
1459 if (!PL_rsfp_filters)
1461 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1462 /* Provide a default input filter to make life easy. */
1463 /* Note that we append to the line. This is handy. */
1465 warn("filter_read %d: from rsfp\n", idx);
1469 int old_len = SvCUR(buf_sv) ;
1471 /* ensure buf_sv is large enough */
1472 SvGROW(buf_sv, old_len + maxlen) ;
1473 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1474 if (PerlIO_error(PL_rsfp))
1475 return -1; /* error */
1477 return 0 ; /* end of file */
1479 SvCUR_set(buf_sv, old_len + len) ;
1482 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1483 if (PerlIO_error(PL_rsfp))
1484 return -1; /* error */
1486 return 0 ; /* end of file */
1489 return SvCUR(buf_sv);
1491 /* Skip this filter slot if filter has been deleted */
1492 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1494 warn("filter_read %d: skipped (filter deleted)\n", idx);
1495 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1497 /* Get function pointer hidden within datasv */
1498 funcp = (filter_t)IoDIRP(datasv);
1500 warn("filter_read %d: via function %p (%s)\n",
1501 idx, funcp, SvPV(datasv,PL_na));
1502 /* Call function. The function is expected to */
1503 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1504 /* Return: <0:error, =0:eof, >0:not eof */
1505 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1509 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1512 if (!PL_rsfp_filters) {
1513 filter_add(win32_textfilter,NULL);
1516 if (PL_rsfp_filters) {
1519 SvCUR_set(sv, 0); /* start with empty line */
1520 if (FILTER_READ(0, sv, 0) > 0)
1521 return ( SvPVX(sv) ) ;
1526 return (sv_gets(sv, fp, append));
1531 static char* exp_name[] =
1532 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1538 Works out what to call the token just pulled out of the input
1539 stream. The yacc parser takes care of taking the ops we return and
1540 stitching them into a tree.
1546 if read an identifier
1547 if we're in a my declaration
1548 croak if they tried to say my($foo::bar)
1549 build the ops for a my() declaration
1550 if it's an access to a my() variable
1551 are we in a sort block?
1552 croak if my($a); $a <=> $b
1553 build ops for access to a my() variable
1554 if in a dq string, and they've said @foo and we can't find @foo
1556 build ops for a bareword
1557 if we already built the token before, use it.
1571 /* check if there's an identifier for us to look at */
1572 if (PL_pending_ident) {
1573 /* pit holds the identifier we read and pending_ident is reset */
1574 char pit = PL_pending_ident;
1575 PL_pending_ident = 0;
1577 /* if we're in a my(), we can't allow dynamics here.
1578 $foo'bar has already been turned into $foo::bar, so
1579 just check for colons.
1581 if it's a legal name, the OP is a PADANY.
1584 if (strchr(PL_tokenbuf,':'))
1585 croak(no_myglob,PL_tokenbuf);
1587 yylval.opval = newOP(OP_PADANY, 0);
1588 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1593 build the ops for accesses to a my() variable.
1595 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1596 then used in a comparison. This catches most, but not
1597 all cases. For instance, it catches
1598 sort { my($a); $a <=> $b }
1600 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1601 (although why you'd do that is anyone's guess).
1604 if (!strchr(PL_tokenbuf,':')) {
1606 /* Check for single character per-thread SVs */
1607 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1608 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1609 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1611 yylval.opval = newOP(OP_THREADSV, 0);
1612 yylval.opval->op_targ = tmp;
1615 #endif /* USE_THREADS */
1616 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1617 /* if it's a sort block and they're naming $a or $b */
1618 if (PL_last_lop_op == OP_SORT &&
1619 PL_tokenbuf[0] == '$' &&
1620 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1623 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1624 d < PL_bufend && *d != '\n';
1627 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1628 croak("Can't use \"my %s\" in sort comparison",
1634 yylval.opval = newOP(OP_PADANY, 0);
1635 yylval.opval->op_targ = tmp;
1641 Whine if they've said @foo in a doublequoted string,
1642 and @foo isn't a variable we can find in the symbol
1645 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1646 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1647 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1648 yyerror(form("In string, %s now must be written as \\%s",
1649 PL_tokenbuf, PL_tokenbuf));
1652 /* build ops for a bareword */
1653 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1654 yylval.opval->op_private = OPpCONST_ENTERED;
1655 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1656 ((PL_tokenbuf[0] == '$') ? SVt_PV
1657 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1662 /* no identifier pending identification */
1664 switch (PL_lex_state) {
1666 case LEX_NORMAL: /* Some compilers will produce faster */
1667 case LEX_INTERPNORMAL: /* code if we comment these out. */
1671 /* when we're already built the next token, just pull it out the queue */
1674 yylval = PL_nextval[PL_nexttoke];
1676 PL_lex_state = PL_lex_defer;
1677 PL_expect = PL_lex_expect;
1678 PL_lex_defer = LEX_NORMAL;
1680 return(PL_nexttype[PL_nexttoke]);
1682 /* interpolated case modifiers like \L \U, including \Q and \E.
1683 when we get here, PL_bufptr is at the \
1685 case LEX_INTERPCASEMOD:
1687 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1688 croak("panic: INTERPCASEMOD");
1690 /* handle \E or end of string */
1691 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1695 if (PL_lex_casemods) {
1696 oldmod = PL_lex_casestack[--PL_lex_casemods];
1697 PL_lex_casestack[PL_lex_casemods] = '\0';
1699 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1701 PL_lex_state = LEX_INTERPCONCAT;
1705 if (PL_bufptr != PL_bufend)
1707 PL_lex_state = LEX_INTERPCONCAT;
1712 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1713 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1714 if (strchr("LU", *s) &&
1715 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1717 PL_lex_casestack[--PL_lex_casemods] = '\0';
1720 if (PL_lex_casemods > 10) {
1721 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1722 if (newlb != PL_lex_casestack) {
1724 PL_lex_casestack = newlb;
1727 PL_lex_casestack[PL_lex_casemods++] = *s;
1728 PL_lex_casestack[PL_lex_casemods] = '\0';
1729 PL_lex_state = LEX_INTERPCONCAT;
1730 PL_nextval[PL_nexttoke].ival = 0;
1733 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1735 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1737 PL_nextval[PL_nexttoke].ival = OP_LC;
1739 PL_nextval[PL_nexttoke].ival = OP_UC;
1741 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1743 croak("panic: yylex");
1746 if (PL_lex_starts) {
1755 case LEX_INTERPPUSH:
1756 return sublex_push();
1758 case LEX_INTERPSTART:
1759 if (PL_bufptr == PL_bufend)
1760 return sublex_done();
1762 PL_lex_dojoin = (*PL_bufptr == '@');
1763 PL_lex_state = LEX_INTERPNORMAL;
1764 if (PL_lex_dojoin) {
1765 PL_nextval[PL_nexttoke].ival = 0;
1768 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1769 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1770 force_next(PRIVATEREF);
1772 force_ident("\"", '$');
1773 #endif /* USE_THREADS */
1774 PL_nextval[PL_nexttoke].ival = 0;
1776 PL_nextval[PL_nexttoke].ival = 0;
1778 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1781 if (PL_lex_starts++) {
1787 case LEX_INTERPENDMAYBE:
1788 if (intuit_more(PL_bufptr)) {
1789 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1795 if (PL_lex_dojoin) {
1796 PL_lex_dojoin = FALSE;
1797 PL_lex_state = LEX_INTERPCONCAT;
1801 case LEX_INTERPCONCAT:
1803 if (PL_lex_brackets)
1804 croak("panic: INTERPCONCAT");
1806 if (PL_bufptr == PL_bufend)
1807 return sublex_done();
1809 if (SvIVX(PL_linestr) == '\'') {
1810 SV *sv = newSVsv(PL_linestr);
1813 else if ( PL_hints & HINT_NEW_RE )
1814 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1815 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1819 s = scan_const(PL_bufptr);
1821 PL_lex_state = LEX_INTERPCASEMOD;
1823 PL_lex_state = LEX_INTERPSTART;
1826 if (s != PL_bufptr) {
1827 PL_nextval[PL_nexttoke] = yylval;
1830 if (PL_lex_starts++)
1840 PL_lex_state = LEX_NORMAL;
1841 s = scan_formline(PL_bufptr);
1842 if (!PL_lex_formbrack)
1848 PL_oldoldbufptr = PL_oldbufptr;
1851 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1858 * Note: we try to be careful never to call the isXXX_utf8() functions unless we're
1859 * pretty sure we've seen the beginning of a UTF-8 character (that is, the two high
1860 * bits are set). Otherwise we risk loading in the heavy-duty SWASHINIT and SWASHGET
1861 * routines unnecessarily. You will see this not just here but throughout this file.
1863 if (UTF && (*s & 0xc0) == 0x80) {
1864 if (isIDFIRST_utf8((U8*)s))
1867 croak("Unrecognized character \\x%02X", *s & 255);
1870 goto fake_eof; /* emulate EOF on ^D or ^Z */
1875 if (PL_lex_brackets)
1876 yyerror("Missing right bracket");
1879 if (s++ < PL_bufend)
1880 goto retry; /* ignore stray nulls */
1883 if (!PL_in_eval && !PL_preambled) {
1884 PL_preambled = TRUE;
1885 sv_setpv(PL_linestr,incl_perldb());
1886 if (SvCUR(PL_linestr))
1887 sv_catpv(PL_linestr,";");
1889 while(AvFILLp(PL_preambleav) >= 0) {
1890 SV *tmpsv = av_shift(PL_preambleav);
1891 sv_catsv(PL_linestr, tmpsv);
1892 sv_catpv(PL_linestr, ";");
1895 sv_free((SV*)PL_preambleav);
1896 PL_preambleav = NULL;
1898 if (PL_minus_n || PL_minus_p) {
1899 sv_catpv(PL_linestr, "LINE: while (<>) {");
1901 sv_catpv(PL_linestr,"chomp;");
1903 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1905 GvIMPORTED_AV_on(gv);
1907 if (strchr("/'\"", *PL_splitstr)
1908 && strchr(PL_splitstr + 1, *PL_splitstr))
1909 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1912 s = "'~#\200\1'"; /* surely one char is unused...*/
1913 while (s[1] && strchr(PL_splitstr, *s)) s++;
1915 sv_catpvf(PL_linestr, "@F=split(%s%c",
1916 "q" + (delim == '\''), delim);
1917 for (s = PL_splitstr; *s; s++) {
1919 sv_catpvn(PL_linestr, "\\", 1);
1920 sv_catpvn(PL_linestr, s, 1);
1922 sv_catpvf(PL_linestr, "%c);", delim);
1926 sv_catpv(PL_linestr,"@F=split(' ');");
1929 sv_catpv(PL_linestr, "\n");
1930 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1931 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1932 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1933 SV *sv = NEWSV(85,0);
1935 sv_upgrade(sv, SVt_PVMG);
1936 sv_setsv(sv,PL_linestr);
1937 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1942 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1945 if (PL_preprocess && !PL_in_eval)
1946 (void)PerlProc_pclose(PL_rsfp);
1947 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1948 PerlIO_clearerr(PL_rsfp);
1950 (void)PerlIO_close(PL_rsfp);
1952 PL_doextract = FALSE;
1954 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1955 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1956 sv_catpv(PL_linestr,";}");
1957 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1958 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1959 PL_minus_n = PL_minus_p = 0;
1962 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1963 sv_setpv(PL_linestr,"");
1964 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1967 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1968 PL_doextract = FALSE;
1970 /* Incest with pod. */
1971 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1972 sv_setpv(PL_linestr, "");
1973 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1974 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1975 PL_doextract = FALSE;
1979 } while (PL_doextract);
1980 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1981 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1982 SV *sv = NEWSV(85,0);
1984 sv_upgrade(sv, SVt_PVMG);
1985 sv_setsv(sv,PL_linestr);
1986 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1988 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1989 if (PL_curcop->cop_line == 1) {
1990 while (s < PL_bufend && isSPACE(*s))
1992 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1996 if (*s == '#' && *(s+1) == '!')
1998 #ifdef ALTERNATE_SHEBANG
2000 static char as[] = ALTERNATE_SHEBANG;
2001 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2002 d = s + (sizeof(as) - 1);
2004 #endif /* ALTERNATE_SHEBANG */
2013 while (*d && !isSPACE(*d))
2017 #ifdef ARG_ZERO_IS_SCRIPT
2018 if (ipathend > ipath) {
2020 * HP-UX (at least) sets argv[0] to the script name,
2021 * which makes $^X incorrect. And Digital UNIX and Linux,
2022 * at least, set argv[0] to the basename of the Perl
2023 * interpreter. So, having found "#!", we'll set it right.
2025 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2026 assert(SvPOK(x) || SvGMAGICAL(x));
2027 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2028 sv_setpvn(x, ipath, ipathend - ipath);
2031 TAINT_NOT; /* $^X is always tainted, but that's OK */
2033 #endif /* ARG_ZERO_IS_SCRIPT */
2038 d = instr(s,"perl -");
2040 d = instr(s,"perl");
2041 #ifdef ALTERNATE_SHEBANG
2043 * If the ALTERNATE_SHEBANG on this system starts with a
2044 * character that can be part of a Perl expression, then if
2045 * we see it but not "perl", we're probably looking at the
2046 * start of Perl code, not a request to hand off to some
2047 * other interpreter. Similarly, if "perl" is there, but
2048 * not in the first 'word' of the line, we assume the line
2049 * contains the start of the Perl program.
2051 if (d && *s != '#') {
2053 while (*c && !strchr("; \t\r\n\f\v#", *c))
2056 d = Nullch; /* "perl" not in first word; ignore */
2058 *s = '#'; /* Don't try to parse shebang line */
2060 #endif /* ALTERNATE_SHEBANG */
2065 !instr(s,"indir") &&
2066 instr(PL_origargv[0],"perl"))
2072 while (s < PL_bufend && isSPACE(*s))
2074 if (s < PL_bufend) {
2075 Newz(899,newargv,PL_origargc+3,char*);
2077 while (s < PL_bufend && !isSPACE(*s))
2080 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2083 newargv = PL_origargv;
2085 execv(ipath, newargv);
2086 croak("Can't exec %s", ipath);
2089 U32 oldpdb = PL_perldb;
2090 bool oldn = PL_minus_n;
2091 bool oldp = PL_minus_p;
2093 while (*d && !isSPACE(*d)) d++;
2094 while (*d == ' ' || *d == '\t') d++;
2098 if (*d == 'M' || *d == 'm') {
2100 while (*d && !isSPACE(*d)) d++;
2101 croak("Too late for \"-%.*s\" option",
2104 d = moreswitches(d);
2106 if (PERLDB_LINE && !oldpdb ||
2107 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2108 /* if we have already added "LINE: while (<>) {",
2109 we must not do it again */
2111 sv_setpv(PL_linestr, "");
2112 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2113 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2114 PL_preambled = FALSE;
2116 (void)gv_fetchfile(PL_origfilename);
2123 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2125 PL_lex_state = LEX_FORMLINE;
2130 #ifdef PERL_STRICT_CR
2131 warn("Illegal character \\%03o (carriage return)", '\r');
2133 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2135 case ' ': case '\t': case '\f': case 013:
2140 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2142 while (s < d && *s != '\n')
2147 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2149 PL_lex_state = LEX_FORMLINE;
2159 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2164 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2167 if (strnEQ(s,"=>",2)) {
2168 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2169 OPERATOR('-'); /* unary minus */
2171 PL_last_uni = PL_oldbufptr;
2172 PL_last_lop_op = OP_FTEREAD; /* good enough */
2174 case 'r': FTST(OP_FTEREAD);
2175 case 'w': FTST(OP_FTEWRITE);
2176 case 'x': FTST(OP_FTEEXEC);
2177 case 'o': FTST(OP_FTEOWNED);
2178 case 'R': FTST(OP_FTRREAD);
2179 case 'W': FTST(OP_FTRWRITE);
2180 case 'X': FTST(OP_FTREXEC);
2181 case 'O': FTST(OP_FTROWNED);
2182 case 'e': FTST(OP_FTIS);
2183 case 'z': FTST(OP_FTZERO);
2184 case 's': FTST(OP_FTSIZE);
2185 case 'f': FTST(OP_FTFILE);
2186 case 'd': FTST(OP_FTDIR);
2187 case 'l': FTST(OP_FTLINK);
2188 case 'p': FTST(OP_FTPIPE);
2189 case 'S': FTST(OP_FTSOCK);
2190 case 'u': FTST(OP_FTSUID);
2191 case 'g': FTST(OP_FTSGID);
2192 case 'k': FTST(OP_FTSVTX);
2193 case 'b': FTST(OP_FTBLK);
2194 case 'c': FTST(OP_FTCHR);
2195 case 't': FTST(OP_FTTTY);
2196 case 'T': FTST(OP_FTTEXT);
2197 case 'B': FTST(OP_FTBINARY);
2198 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2199 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2200 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2202 croak("Unrecognized file test: -%c", (int)tmp);
2209 if (PL_expect == XOPERATOR)
2214 else if (*s == '>') {
2217 if (isIDFIRST(*s)) {
2218 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2226 if (PL_expect == XOPERATOR)
2229 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2231 OPERATOR('-'); /* unary minus */
2238 if (PL_expect == XOPERATOR)
2243 if (PL_expect == XOPERATOR)
2246 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2252 if (PL_expect != XOPERATOR) {
2253 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2254 PL_expect = XOPERATOR;
2255 force_ident(PL_tokenbuf, '*');
2268 if (PL_expect == XOPERATOR) {
2272 PL_tokenbuf[0] = '%';
2273 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2274 if (!PL_tokenbuf[1]) {
2276 yyerror("Final % should be \\% or %name");
2279 PL_pending_ident = '%';
2301 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2302 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2307 if (PL_curcop->cop_line < PL_copline)
2308 PL_copline = PL_curcop->cop_line;
2319 if (PL_lex_brackets <= 0)
2320 yyerror("Unmatched right bracket");
2323 if (PL_lex_state == LEX_INTERPNORMAL) {
2324 if (PL_lex_brackets == 0) {
2325 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2326 PL_lex_state = LEX_INTERPEND;
2333 if (PL_lex_brackets > 100) {
2334 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2335 if (newlb != PL_lex_brackstack) {
2337 PL_lex_brackstack = newlb;
2340 switch (PL_expect) {
2342 if (PL_lex_formbrack) {
2346 if (PL_oldoldbufptr == PL_last_lop)
2347 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2349 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2350 OPERATOR(HASHBRACK);
2352 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2355 PL_tokenbuf[0] = '\0';
2356 if (d < PL_bufend && *d == '-') {
2357 PL_tokenbuf[0] = '-';
2359 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2362 if (d < PL_bufend && isIDFIRST(*d)) {
2363 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2365 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2368 char minus = (PL_tokenbuf[0] == '-');
2369 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2376 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2380 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2385 if (PL_oldoldbufptr == PL_last_lop)
2386 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2388 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2391 OPERATOR(HASHBRACK);
2392 /* This hack serves to disambiguate a pair of curlies
2393 * as being a block or an anon hash. Normally, expectation
2394 * determines that, but in cases where we're not in a
2395 * position to expect anything in particular (like inside
2396 * eval"") we have to resolve the ambiguity. This code
2397 * covers the case where the first term in the curlies is a
2398 * quoted string. Most other cases need to be explicitly
2399 * disambiguated by prepending a `+' before the opening
2400 * curly in order to force resolution as an anon hash.
2402 * XXX should probably propagate the outer expectation
2403 * into eval"" to rely less on this hack, but that could
2404 * potentially break current behavior of eval"".
2408 if (*s == '\'' || *s == '"' || *s == '`') {
2409 /* common case: get past first string, handling escapes */
2410 for (t++; t < PL_bufend && *t != *s;)
2411 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2415 else if (*s == 'q') {
2418 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2419 && !isALNUM(*t)))) {
2421 char open, close, term;
2424 while (t < PL_bufend && isSPACE(*t))
2428 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2432 for (t++; t < PL_bufend; t++) {
2433 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2435 else if (*t == open)
2439 for (t++; t < PL_bufend; t++) {
2440 if (*t == '\\' && t+1 < PL_bufend)
2442 else if (*t == close && --brackets <= 0)
2444 else if (*t == open)
2450 else if (isALPHA(*s)) {
2451 for (t++; t < PL_bufend && isALNUM(*t); t++) ;
2453 while (t < PL_bufend && isSPACE(*t))
2455 /* if comma follows first term, call it an anon hash */
2456 /* XXX it could be a comma expression with loop modifiers */
2457 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2458 || (*t == '=' && t[1] == '>')))
2459 OPERATOR(HASHBRACK);
2460 if (PL_expect == XREF)
2463 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2469 yylval.ival = PL_curcop->cop_line;
2470 if (isSPACE(*s) || *s == '#')
2471 PL_copline = NOLINE; /* invalidate current command line number */
2476 if (PL_lex_brackets <= 0)
2477 yyerror("Unmatched right bracket");
2479 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2480 if (PL_lex_brackets < PL_lex_formbrack)
2481 PL_lex_formbrack = 0;
2482 if (PL_lex_state == LEX_INTERPNORMAL) {
2483 if (PL_lex_brackets == 0) {
2484 if (PL_lex_fakebrack) {
2485 PL_lex_state = LEX_INTERPEND;
2487 return yylex(); /* ignore fake brackets */
2489 if (*s == '-' && s[1] == '>')
2490 PL_lex_state = LEX_INTERPENDMAYBE;
2491 else if (*s != '[' && *s != '{')
2492 PL_lex_state = LEX_INTERPEND;
2495 if (PL_lex_brackets < PL_lex_fakebrack) {
2497 PL_lex_fakebrack = 0;
2498 return yylex(); /* ignore fake brackets */
2508 if (PL_expect == XOPERATOR) {
2509 if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && PL_bufptr == PL_linestart) {
2510 PL_curcop->cop_line--;
2511 warner(WARN_SEMICOLON, warn_nosemi);
2512 PL_curcop->cop_line++;
2517 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2519 PL_expect = XOPERATOR;
2520 force_ident(PL_tokenbuf, '&');
2524 yylval.ival = (OPpENTERSUB_AMPER<<8);
2543 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2544 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2546 if (PL_expect == XSTATE && isALPHA(tmp) &&
2547 (s == PL_linestart+1 || s[-2] == '\n') )
2549 if (PL_in_eval && !PL_rsfp) {
2554 if (strnEQ(s,"=cut",4)) {
2568 PL_doextract = TRUE;
2571 if (PL_lex_brackets < PL_lex_formbrack) {
2573 #ifdef PERL_STRICT_CR
2574 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2576 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2578 if (*t == '\n' || *t == '#') {
2596 if (PL_expect != XOPERATOR) {
2597 if (s[1] != '<' && !strchr(s,'>'))
2600 s = scan_heredoc(s);
2602 s = scan_inputsymbol(s);
2603 TERM(sublex_start());
2608 SHop(OP_LEFT_SHIFT);
2622 SHop(OP_RIGHT_SHIFT);
2631 if (PL_expect == XOPERATOR) {
2632 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2635 return ','; /* grandfather non-comma-format format */
2639 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:+-", s[2]))) {
2640 if (PL_expect == XOPERATOR)
2641 no_op("Array length", PL_bufptr);
2642 PL_tokenbuf[0] = '@';
2643 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2645 if (!PL_tokenbuf[1])
2647 PL_expect = XOPERATOR;
2648 PL_pending_ident = '#';
2652 if (PL_expect == XOPERATOR)
2653 no_op("Scalar", PL_bufptr);
2654 PL_tokenbuf[0] = '$';
2655 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2656 if (!PL_tokenbuf[1]) {
2658 yyerror("Final $ should be \\$ or $name");
2662 /* This kludge not intended to be bulletproof. */
2663 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2664 yylval.opval = newSVOP(OP_CONST, 0,
2665 newSViv((IV)PL_compiling.cop_arybase));
2666 yylval.opval->op_private = OPpCONST_ARYBASE;
2671 if (PL_lex_state == LEX_NORMAL)
2674 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2677 PL_tokenbuf[0] = '@';
2678 if (ckWARN(WARN_SYNTAX)) {
2680 isSPACE(*t) || isALNUM(*t) || *t == '$';
2683 PL_bufptr = skipspace(PL_bufptr);
2684 while (t < PL_bufend && *t != ']')
2687 "Multidimensional syntax %.*s not supported",
2688 (t - PL_bufptr) + 1, PL_bufptr);
2692 else if (*s == '{') {
2693 PL_tokenbuf[0] = '%';
2694 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2695 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2697 char tmpbuf[sizeof PL_tokenbuf];
2699 for (t++; isSPACE(*t); t++) ;
2700 if (isIDFIRST(*t)) {
2701 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2702 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2704 "You need to quote \"%s\"", tmpbuf);
2710 PL_expect = XOPERATOR;
2711 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2712 bool islop = (PL_last_lop == PL_oldoldbufptr);
2713 if (!islop || PL_last_lop_op == OP_GREPSTART)
2714 PL_expect = XOPERATOR;
2715 else if (strchr("$@\"'`q", *s))
2716 PL_expect = XTERM; /* e.g. print $fh "foo" */
2717 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2718 PL_expect = XTERM; /* e.g. print $fh &sub */
2719 else if (isIDFIRST(*s)) {
2720 char tmpbuf[sizeof PL_tokenbuf];
2721 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2722 if (tmp = keyword(tmpbuf, len)) {
2723 /* binary operators exclude handle interpretations */
2735 PL_expect = XTERM; /* e.g. print $fh length() */
2740 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2741 if (gv && GvCVu(gv))
2742 PL_expect = XTERM; /* e.g. print $fh subr() */
2745 else if (isDIGIT(*s))
2746 PL_expect = XTERM; /* e.g. print $fh 3 */
2747 else if (*s == '.' && isDIGIT(s[1]))
2748 PL_expect = XTERM; /* e.g. print $fh .3 */
2749 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2750 PL_expect = XTERM; /* e.g. print $fh -1 */
2751 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2752 PL_expect = XTERM; /* print $fh <<"EOF" */
2754 PL_pending_ident = '$';
2758 if (PL_expect == XOPERATOR)
2760 PL_tokenbuf[0] = '@';
2761 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2762 if (!PL_tokenbuf[1]) {
2764 yyerror("Final @ should be \\@ or @name");
2767 if (PL_lex_state == LEX_NORMAL)
2769 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2771 PL_tokenbuf[0] = '%';
2773 /* Warn about @ where they meant $. */
2774 if (ckWARN(WARN_SYNTAX)) {
2775 if (*s == '[' || *s == '{') {
2777 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2779 if (*t == '}' || *t == ']') {
2781 PL_bufptr = skipspace(PL_bufptr);
2783 "Scalar value %.*s better written as $%.*s",
2784 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2789 PL_pending_ident = '@';
2792 case '/': /* may either be division or pattern */
2793 case '?': /* may either be conditional or pattern */
2794 if (PL_expect != XOPERATOR) {
2795 /* Disable warning on "study /blah/" */
2796 if (PL_oldoldbufptr == PL_last_uni
2797 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2798 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2800 s = scan_pat(s,OP_MATCH);
2801 TERM(sublex_start());
2809 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2810 #ifdef PERL_STRICT_CR
2813 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2815 && (s == PL_linestart || s[-1] == '\n') )
2817 PL_lex_formbrack = 0;
2821 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2827 yylval.ival = OPf_SPECIAL;
2833 if (PL_expect != XOPERATOR)
2838 case '0': case '1': case '2': case '3': case '4':
2839 case '5': case '6': case '7': case '8': case '9':
2841 if (PL_expect == XOPERATOR)
2847 if (PL_expect == XOPERATOR) {
2848 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2851 return ','; /* grandfather non-comma-format format */
2857 missingterm((char*)0);
2858 yylval.ival = OP_CONST;
2859 TERM(sublex_start());
2863 if (PL_expect == XOPERATOR) {
2864 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2867 return ','; /* grandfather non-comma-format format */
2873 missingterm((char*)0);
2874 yylval.ival = OP_CONST;
2875 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2876 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2877 yylval.ival = OP_STRINGIFY;
2881 TERM(sublex_start());
2885 if (PL_expect == XOPERATOR)
2886 no_op("Backticks",s);
2888 missingterm((char*)0);
2889 yylval.ival = OP_BACKTICK;
2891 TERM(sublex_start());
2895 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2896 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2898 if (PL_expect == XOPERATOR)
2899 no_op("Backslash",s);
2903 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2942 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2944 /* Some keywords can be followed by any delimiter, including ':' */
2945 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2946 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2947 (PL_tokenbuf[0] == 'q' &&
2948 strchr("qwxr", PL_tokenbuf[1]))));
2950 /* x::* is just a word, unless x is "CORE" */
2951 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2955 while (d < PL_bufend && isSPACE(*d))
2956 d++; /* no comments skipped here, or s### is misparsed */
2958 /* Is this a label? */
2959 if (!tmp && PL_expect == XSTATE
2960 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2962 yylval.pval = savepv(PL_tokenbuf);
2967 /* Check for keywords */
2968 tmp = keyword(PL_tokenbuf, len);
2970 /* Is this a word before a => operator? */
2971 if (strnEQ(d,"=>",2)) {
2973 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2974 yylval.opval->op_private = OPpCONST_BARE;
2978 if (tmp < 0) { /* second-class keyword? */
2979 GV *ogv = Nullgv; /* override (winner) */
2980 GV *hgv = Nullgv; /* hidden (loser) */
2981 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2983 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
2986 if (GvIMPORTED_CV(gv))
2988 else if (! CvMETHOD(cv))
2992 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2993 (gv = *gvp) != (GV*)&PL_sv_undef &&
2994 GvCVu(gv) && GvIMPORTED_CV(gv))
3000 tmp = 0; /* overridden by import or by GLOBAL */
3003 && -tmp==KEY_lock /* XXX generalizable kludge */
3004 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3006 tmp = 0; /* any sub overrides "weak" keyword */
3008 else { /* no override */
3012 if (ckWARN(WARN_AMBIGUOUS) && hgv
3013 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3014 warner(WARN_AMBIGUOUS,
3015 "Ambiguous call resolved as CORE::%s(), %s",
3016 GvENAME(hgv), "qualify as such or use &");
3023 default: /* not a keyword */
3026 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3028 /* Get the rest if it looks like a package qualifier */
3030 if (*s == '\'' || *s == ':' && s[1] == ':') {
3032 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3035 croak("Bad name after %s%s", PL_tokenbuf,
3036 *s == '\'' ? "'" : "::");
3040 if (PL_expect == XOPERATOR) {
3041 if (PL_bufptr == PL_linestart) {
3042 PL_curcop->cop_line--;
3043 warner(WARN_SEMICOLON, warn_nosemi);
3044 PL_curcop->cop_line++;
3047 no_op("Bareword",s);
3050 /* Look for a subroutine with this name in current package,
3051 unless name is "Foo::", in which case Foo is a bearword
3052 (and a package name). */
3055 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3057 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3059 "Bareword \"%s\" refers to nonexistent package",
3062 PL_tokenbuf[len] = '\0';
3069 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3072 /* if we saw a global override before, get the right name */
3075 sv = newSVpv("CORE::GLOBAL::",14);
3076 sv_catpv(sv,PL_tokenbuf);
3079 sv = newSVpv(PL_tokenbuf,0);
3081 /* Presume this is going to be a bareword of some sort. */
3084 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3085 yylval.opval->op_private = OPpCONST_BARE;
3087 /* And if "Foo::", then that's what it certainly is. */
3092 /* See if it's the indirect object for a list operator. */
3094 if (PL_oldoldbufptr &&
3095 PL_oldoldbufptr < PL_bufptr &&
3096 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3097 /* NO SKIPSPACE BEFORE HERE! */
3099 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3100 || (PL_last_lop_op == OP_ENTERSUB
3102 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3104 bool immediate_paren = *s == '(';
3106 /* (Now we can afford to cross potential line boundary.) */
3109 /* Two barewords in a row may indicate method call. */
3111 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
3114 /* If not a declared subroutine, it's an indirect object. */
3115 /* (But it's an indir obj regardless for sort.) */
3117 if ((PL_last_lop_op == OP_SORT ||
3118 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3119 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3120 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3125 /* If followed by a paren, it's certainly a subroutine. */
3127 PL_expect = XOPERATOR;
3131 if (gv && GvCVu(gv)) {
3132 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3133 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3138 PL_nextval[PL_nexttoke].opval = yylval.opval;
3139 PL_expect = XOPERATOR;
3145 /* If followed by var or block, call it a method (unless sub) */
3147 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3148 PL_last_lop = PL_oldbufptr;
3149 PL_last_lop_op = OP_METHOD;
3153 /* If followed by a bareword, see if it looks like indir obj. */
3155 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3158 /* Not a method, so call it a subroutine (if defined) */
3160 if (gv && GvCVu(gv)) {
3162 if (lastchar == '-')
3163 warn("Ambiguous use of -%s resolved as -&%s()",
3164 PL_tokenbuf, PL_tokenbuf);
3165 PL_last_lop = PL_oldbufptr;
3166 PL_last_lop_op = OP_ENTERSUB;
3167 /* Check for a constant sub */
3169 if ((sv = cv_const_sv(cv))) {
3171 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3172 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3173 yylval.opval->op_private = 0;
3177 /* Resolve to GV now. */
3178 op_free(yylval.opval);
3179 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3180 /* Is there a prototype? */
3183 PL_last_proto = SvPV((SV*)cv, len);
3186 if (strEQ(PL_last_proto, "$"))
3188 if (*PL_last_proto == '&' && *s == '{') {
3189 sv_setpv(PL_subname,"__ANON__");
3193 PL_last_proto = NULL;
3194 PL_nextval[PL_nexttoke].opval = yylval.opval;
3200 if (PL_hints & HINT_STRICT_SUBS &&
3203 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3204 PL_last_lop_op != OP_ACCEPT &&
3205 PL_last_lop_op != OP_PIPE_OP &&
3206 PL_last_lop_op != OP_SOCKPAIR)
3209 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3214 /* Call it a bare word */
3217 if (ckWARN(WARN_RESERVED)) {
3218 if (lastchar != '-') {
3219 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3221 warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
3226 if (lastchar && strchr("*%&", lastchar)) {
3227 warn("Operator or semicolon missing before %c%s",
3228 lastchar, PL_tokenbuf);
3229 warn("Ambiguous use of %c resolved as operator %c",
3230 lastchar, lastchar);
3236 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3237 newSVsv(GvSV(PL_curcop->cop_filegv)));
3241 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3242 newSVpvf("%ld", (long)PL_curcop->cop_line));
3245 case KEY___PACKAGE__:
3246 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3248 ? newSVsv(PL_curstname)
3257 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3258 char *pname = "main";
3259 if (PL_tokenbuf[2] == 'D')
3260 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3261 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3264 GvIOp(gv) = newIO();
3265 IoIFP(GvIOp(gv)) = PL_rsfp;
3266 #if defined(HAS_FCNTL) && defined(F_SETFD)
3268 int fd = PerlIO_fileno(PL_rsfp);
3269 fcntl(fd,F_SETFD,fd >= 3);
3272 /* Mark this internal pseudo-handle as clean */
3273 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3275 IoTYPE(GvIOp(gv)) = '|';
3276 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3277 IoTYPE(GvIOp(gv)) = '-';
3279 IoTYPE(GvIOp(gv)) = '<';
3290 if (PL_expect == XSTATE) {
3297 if (*s == ':' && s[1] == ':') {
3300 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3301 tmp = keyword(PL_tokenbuf, len);
3315 LOP(OP_ACCEPT,XTERM);
3321 LOP(OP_ATAN2,XTERM);
3330 LOP(OP_BLESS,XTERM);
3339 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3356 if (!PL_cryptseen++)
3359 LOP(OP_CRYPT,XTERM);
3362 if (ckWARN(WARN_OCTAL)) {
3363 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3364 if (*d != '0' && isDIGIT(*d))
3365 yywarn("chmod: mode argument is missing initial 0");
3367 LOP(OP_CHMOD,XTERM);
3370 LOP(OP_CHOWN,XTERM);
3373 LOP(OP_CONNECT,XTERM);
3389 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3393 PL_hints |= HINT_BLOCK_SCOPE;
3403 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3404 LOP(OP_DBMOPEN,XTERM);
3410 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3417 yylval.ival = PL_curcop->cop_line;
3431 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3432 UNIBRACK(OP_ENTEREVAL);
3447 case KEY_endhostent:
3453 case KEY_endservent:
3456 case KEY_endprotoent:
3467 yylval.ival = PL_curcop->cop_line;
3469 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3471 if ((PL_bufend - p) >= 3 &&
3472 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3476 croak("Missing $ on loop variable");
3481 LOP(OP_FORMLINE,XTERM);
3487 LOP(OP_FCNTL,XTERM);
3493 LOP(OP_FLOCK,XTERM);
3502 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3505 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3520 case KEY_getpriority:
3521 LOP(OP_GETPRIORITY,XTERM);
3523 case KEY_getprotobyname:
3526 case KEY_getprotobynumber:
3527 LOP(OP_GPBYNUMBER,XTERM);
3529 case KEY_getprotoent:
3541 case KEY_getpeername:
3542 UNI(OP_GETPEERNAME);
3544 case KEY_gethostbyname:
3547 case KEY_gethostbyaddr:
3548 LOP(OP_GHBYADDR,XTERM);
3550 case KEY_gethostent:
3553 case KEY_getnetbyname:
3556 case KEY_getnetbyaddr:
3557 LOP(OP_GNBYADDR,XTERM);
3562 case KEY_getservbyname:
3563 LOP(OP_GSBYNAME,XTERM);
3565 case KEY_getservbyport:
3566 LOP(OP_GSBYPORT,XTERM);
3568 case KEY_getservent:
3571 case KEY_getsockname:
3572 UNI(OP_GETSOCKNAME);
3574 case KEY_getsockopt:
3575 LOP(OP_GSOCKOPT,XTERM);
3597 yylval.ival = PL_curcop->cop_line;
3601 LOP(OP_INDEX,XTERM);
3607 LOP(OP_IOCTL,XTERM);
3619 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3650 LOP(OP_LISTEN,XTERM);
3659 s = scan_pat(s,OP_MATCH);
3660 TERM(sublex_start());
3663 LOP(OP_MAPSTART,XREF);
3666 LOP(OP_MKDIR,XTERM);
3669 LOP(OP_MSGCTL,XTERM);
3672 LOP(OP_MSGGET,XTERM);
3675 LOP(OP_MSGRCV,XTERM);
3678 LOP(OP_MSGSND,XTERM);
3683 if (isIDFIRST(*s)) {
3684 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3685 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3686 if (!PL_in_my_stash) {
3689 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3696 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3703 if (PL_expect != XSTATE)
3704 yyerror("\"no\" not allowed in expression");
3705 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3706 s = force_version(s);
3715 if (isIDFIRST(*s)) {
3717 for (d = s; isALNUM(*d); d++) ;
3719 if (strchr("|&*+-=!?:.", *t))
3720 warn("Precedence problem: open %.*s should be open(%.*s)",
3726 yylval.ival = OP_OR;
3736 LOP(OP_OPEN_DIR,XTERM);
3739 checkcomma(s,PL_tokenbuf,"filehandle");
3743 checkcomma(s,PL_tokenbuf,"filehandle");
3762 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3766 LOP(OP_PIPE_OP,XTERM);
3771 missingterm((char*)0);
3772 yylval.ival = OP_CONST;
3773 TERM(sublex_start());
3781 missingterm((char*)0);
3782 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3783 d = SvPV_force(PL_lex_stuff, len);
3784 for (; len; --len, ++d) {
3787 "Possible attempt to separate words with commas");
3792 "Possible attempt to put comments in qw() list");
3798 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3799 PL_lex_stuff = Nullsv;
3802 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3805 yylval.ival = OP_SPLIT;
3809 PL_last_lop = PL_oldbufptr;
3810 PL_last_lop_op = OP_SPLIT;
3816 missingterm((char*)0);
3817 yylval.ival = OP_STRINGIFY;
3818 if (SvIVX(PL_lex_stuff) == '\'')
3819 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3820 TERM(sublex_start());
3823 s = scan_pat(s,OP_QR);
3824 TERM(sublex_start());
3829 missingterm((char*)0);
3830 yylval.ival = OP_BACKTICK;
3832 TERM(sublex_start());
3838 *PL_tokenbuf = '\0';
3839 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3840 if (isIDFIRST(*PL_tokenbuf))
3841 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3843 yyerror("<> should be quotes");
3850 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3854 LOP(OP_RENAME,XTERM);
3863 LOP(OP_RINDEX,XTERM);
3886 LOP(OP_REVERSE,XTERM);
3897 TERM(sublex_start());
3899 TOKEN(1); /* force error */
3908 LOP(OP_SELECT,XTERM);
3914 LOP(OP_SEMCTL,XTERM);
3917 LOP(OP_SEMGET,XTERM);
3920 LOP(OP_SEMOP,XTERM);
3926 LOP(OP_SETPGRP,XTERM);
3928 case KEY_setpriority:
3929 LOP(OP_SETPRIORITY,XTERM);
3931 case KEY_sethostent:
3937 case KEY_setservent:
3940 case KEY_setprotoent:
3950 LOP(OP_SEEKDIR,XTERM);
3952 case KEY_setsockopt:
3953 LOP(OP_SSOCKOPT,XTERM);
3959 LOP(OP_SHMCTL,XTERM);
3962 LOP(OP_SHMGET,XTERM);
3965 LOP(OP_SHMREAD,XTERM);
3968 LOP(OP_SHMWRITE,XTERM);
3971 LOP(OP_SHUTDOWN,XTERM);
3980 LOP(OP_SOCKET,XTERM);
3982 case KEY_socketpair:
3983 LOP(OP_SOCKPAIR,XTERM);
3986 checkcomma(s,PL_tokenbuf,"subroutine name");
3988 if (*s == ';' || *s == ')') /* probably a close */
3989 croak("sort is now a reserved word");
3991 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3995 LOP(OP_SPLIT,XTERM);
3998 LOP(OP_SPRINTF,XTERM);
4001 LOP(OP_SPLICE,XTERM);
4017 LOP(OP_SUBSTR,XTERM);
4024 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
4025 char tmpbuf[sizeof PL_tokenbuf];
4027 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4028 if (strchr(tmpbuf, ':'))
4029 sv_setpv(PL_subname, tmpbuf);
4031 sv_setsv(PL_subname,PL_curstname);
4032 sv_catpvn(PL_subname,"::",2);
4033 sv_catpvn(PL_subname,tmpbuf,len);
4035 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4039 PL_expect = XTERMBLOCK;
4040 sv_setpv(PL_subname,"?");
4043 if (tmp == KEY_format) {
4046 PL_lex_formbrack = PL_lex_brackets + 1;
4050 /* Look for a prototype */
4057 SvREFCNT_dec(PL_lex_stuff);
4058 PL_lex_stuff = Nullsv;
4059 croak("Prototype not terminated");
4062 d = SvPVX(PL_lex_stuff);
4064 for (p = d; *p; ++p) {
4069 SvCUR(PL_lex_stuff) = tmp;
4072 PL_nextval[1] = PL_nextval[0];
4073 PL_nexttype[1] = PL_nexttype[0];
4074 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4075 PL_nexttype[0] = THING;
4076 if (PL_nexttoke == 1) {
4077 PL_lex_defer = PL_lex_state;
4078 PL_lex_expect = PL_expect;
4079 PL_lex_state = LEX_KNOWNEXT;
4081 PL_lex_stuff = Nullsv;
4084 if (*SvPV(PL_subname,PL_na) == '?') {
4085 sv_setpv(PL_subname,"__ANON__");
4092 LOP(OP_SYSTEM,XREF);
4095 LOP(OP_SYMLINK,XTERM);
4098 LOP(OP_SYSCALL,XTERM);
4101 LOP(OP_SYSOPEN,XTERM);
4104 LOP(OP_SYSSEEK,XTERM);
4107 LOP(OP_SYSREAD,XTERM);
4110 LOP(OP_SYSWRITE,XTERM);
4114 TERM(sublex_start());
4135 LOP(OP_TRUNCATE,XTERM);
4147 yylval.ival = PL_curcop->cop_line;
4151 yylval.ival = PL_curcop->cop_line;
4155 LOP(OP_UNLINK,XTERM);
4161 LOP(OP_UNPACK,XTERM);
4164 LOP(OP_UTIME,XTERM);
4167 if (ckWARN(WARN_OCTAL)) {
4168 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4169 if (*d != '0' && isDIGIT(*d))
4170 yywarn("umask: argument is missing initial 0");
4175 LOP(OP_UNSHIFT,XTERM);
4178 if (PL_expect != XSTATE)
4179 yyerror("\"use\" not allowed in expression");
4182 s = force_version(s);
4183 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4184 PL_nextval[PL_nexttoke].opval = Nullop;
4189 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4190 s = force_version(s);
4203 yylval.ival = PL_curcop->cop_line;
4207 PL_hints |= HINT_BLOCK_SCOPE;
4214 LOP(OP_WAITPID,XTERM);
4222 static char ctl_l[2];
4224 if (ctl_l[0] == '\0')
4225 ctl_l[0] = toCTRL('L');
4226 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4229 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4234 if (PL_expect == XOPERATOR)
4240 yylval.ival = OP_XOR;
4245 TERM(sublex_start());
4251 keyword(register char *d, I32 len)
4256 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4257 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4258 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4259 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4260 if (strEQ(d,"__END__")) return KEY___END__;
4264 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4269 if (strEQ(d,"and")) return -KEY_and;
4270 if (strEQ(d,"abs")) return -KEY_abs;
4273 if (strEQ(d,"alarm")) return -KEY_alarm;
4274 if (strEQ(d,"atan2")) return -KEY_atan2;
4277 if (strEQ(d,"accept")) return -KEY_accept;
4282 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4285 if (strEQ(d,"bless")) return -KEY_bless;
4286 if (strEQ(d,"bind")) return -KEY_bind;
4287 if (strEQ(d,"binmode")) return -KEY_binmode;
4290 if (strEQ(d,"CORE")) return -KEY_CORE;
4295 if (strEQ(d,"cmp")) return -KEY_cmp;
4296 if (strEQ(d,"chr")) return -KEY_chr;
4297 if (strEQ(d,"cos")) return -KEY_cos;
4300 if (strEQ(d,"chop")) return KEY_chop;
4303 if (strEQ(d,"close")) return -KEY_close;
4304 if (strEQ(d,"chdir")) return -KEY_chdir;
4305 if (strEQ(d,"chomp")) return KEY_chomp;
4306 if (strEQ(d,"chmod")) return -KEY_chmod;
4307 if (strEQ(d,"chown")) return -KEY_chown;
4308 if (strEQ(d,"crypt")) return -KEY_crypt;
4311 if (strEQ(d,"chroot")) return -KEY_chroot;
4312 if (strEQ(d,"caller")) return -KEY_caller;
4315 if (strEQ(d,"connect")) return -KEY_connect;
4318 if (strEQ(d,"closedir")) return -KEY_closedir;
4319 if (strEQ(d,"continue")) return -KEY_continue;
4324 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4329 if (strEQ(d,"do")) return KEY_do;
4332 if (strEQ(d,"die")) return -KEY_die;
4335 if (strEQ(d,"dump")) return -KEY_dump;
4338 if (strEQ(d,"delete")) return KEY_delete;
4341 if (strEQ(d,"defined")) return KEY_defined;
4342 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4345 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4350 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4351 if (strEQ(d,"END")) return KEY_END;
4356 if (strEQ(d,"eq")) return -KEY_eq;
4359 if (strEQ(d,"eof")) return -KEY_eof;
4360 if (strEQ(d,"exp")) return -KEY_exp;
4363 if (strEQ(d,"else")) return KEY_else;
4364 if (strEQ(d,"exit")) return -KEY_exit;
4365 if (strEQ(d,"eval")) return KEY_eval;
4366 if (strEQ(d,"exec")) return -KEY_exec;
4367 if (strEQ(d,"each")) return KEY_each;
4370 if (strEQ(d,"elsif")) return KEY_elsif;
4373 if (strEQ(d,"exists")) return KEY_exists;
4374 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4377 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4378 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4381 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4384 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4385 if (strEQ(d,"endservent")) return -KEY_endservent;
4388 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4395 if (strEQ(d,"for")) return KEY_for;
4398 if (strEQ(d,"fork")) return -KEY_fork;
4401 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4402 if (strEQ(d,"flock")) return -KEY_flock;
4405 if (strEQ(d,"format")) return KEY_format;
4406 if (strEQ(d,"fileno")) return -KEY_fileno;
4409 if (strEQ(d,"foreach")) return KEY_foreach;
4412 if (strEQ(d,"formline")) return -KEY_formline;
4418 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4419 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4423 if (strnEQ(d,"get",3)) {
4428 if (strEQ(d,"ppid")) return -KEY_getppid;
4429 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4432 if (strEQ(d,"pwent")) return -KEY_getpwent;
4433 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4434 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4437 if (strEQ(d,"peername")) return -KEY_getpeername;
4438 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4439 if (strEQ(d,"priority")) return -KEY_getpriority;
4442 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4445 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4449 else if (*d == 'h') {
4450 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4451 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4452 if (strEQ(d,"hostent")) return -KEY_gethostent;
4454 else if (*d == 'n') {
4455 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4456 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4457 if (strEQ(d,"netent")) return -KEY_getnetent;
4459 else if (*d == 's') {
4460 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4461 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4462 if (strEQ(d,"servent")) return -KEY_getservent;
4463 if (strEQ(d,"sockname")) return -KEY_getsockname;
4464 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4466 else if (*d == 'g') {
4467 if (strEQ(d,"grent")) return -KEY_getgrent;
4468 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4469 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4471 else if (*d == 'l') {
4472 if (strEQ(d,"login")) return -KEY_getlogin;
4474 else if (strEQ(d,"c")) return -KEY_getc;
4479 if (strEQ(d,"gt")) return -KEY_gt;
4480 if (strEQ(d,"ge")) return -KEY_ge;
4483 if (strEQ(d,"grep")) return KEY_grep;
4484 if (strEQ(d,"goto")) return KEY_goto;
4485 if (strEQ(d,"glob")) return KEY_glob;
4488 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4493 if (strEQ(d,"hex")) return -KEY_hex;
4496 if (strEQ(d,"INIT")) return KEY_INIT;
4501 if (strEQ(d,"if")) return KEY_if;
4504 if (strEQ(d,"int")) return -KEY_int;
4507 if (strEQ(d,"index")) return -KEY_index;
4508 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4513 if (strEQ(d,"join")) return -KEY_join;
4517 if (strEQ(d,"keys")) return KEY_keys;
4518 if (strEQ(d,"kill")) return -KEY_kill;
4523 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4524 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4530 if (strEQ(d,"lt")) return -KEY_lt;
4531 if (strEQ(d,"le")) return -KEY_le;
4532 if (strEQ(d,"lc")) return -KEY_lc;
4535 if (strEQ(d,"log")) return -KEY_log;
4538 if (strEQ(d,"last")) return KEY_last;
4539 if (strEQ(d,"link")) return -KEY_link;
4540 if (strEQ(d,"lock")) return -KEY_lock;
4543 if (strEQ(d,"local")) return KEY_local;
4544 if (strEQ(d,"lstat")) return -KEY_lstat;
4547 if (strEQ(d,"length")) return -KEY_length;
4548 if (strEQ(d,"listen")) return -KEY_listen;
4551 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4554 if (strEQ(d,"localtime")) return -KEY_localtime;
4560 case 1: return KEY_m;
4562 if (strEQ(d,"my")) return KEY_my;
4565 if (strEQ(d,"map")) return KEY_map;
4568 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4571 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4572 if (strEQ(d,"msgget")) return -KEY_msgget;
4573 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4574 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4579 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4582 if (strEQ(d,"next")) return KEY_next;
4583 if (strEQ(d,"ne")) return -KEY_ne;
4584 if (strEQ(d,"not")) return -KEY_not;
4585 if (strEQ(d,"no")) return KEY_no;
4590 if (strEQ(d,"or")) return -KEY_or;
4593 if (strEQ(d,"ord")) return -KEY_ord;
4594 if (strEQ(d,"oct")) return -KEY_oct;
4595 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4599 if (strEQ(d,"open")) return -KEY_open;
4602 if (strEQ(d,"opendir")) return -KEY_opendir;
4609 if (strEQ(d,"pop")) return KEY_pop;
4610 if (strEQ(d,"pos")) return KEY_pos;
4613 if (strEQ(d,"push")) return KEY_push;
4614 if (strEQ(d,"pack")) return -KEY_pack;
4615 if (strEQ(d,"pipe")) return -KEY_pipe;
4618 if (strEQ(d,"print")) return KEY_print;
4621 if (strEQ(d,"printf")) return KEY_printf;
4624 if (strEQ(d,"package")) return KEY_package;
4627 if (strEQ(d,"prototype")) return KEY_prototype;
4632 if (strEQ(d,"q")) return KEY_q;
4633 if (strEQ(d,"qr")) return KEY_qr;
4634 if (strEQ(d,"qq")) return KEY_qq;
4635 if (strEQ(d,"qw")) return KEY_qw;
4636 if (strEQ(d,"qx")) return KEY_qx;
4638 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4643 if (strEQ(d,"ref")) return -KEY_ref;
4646 if (strEQ(d,"read")) return -KEY_read;
4647 if (strEQ(d,"rand")) return -KEY_rand;
4648 if (strEQ(d,"recv")) return -KEY_recv;
4649 if (strEQ(d,"redo")) return KEY_redo;
4652 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4653 if (strEQ(d,"reset")) return -KEY_reset;
4656 if (strEQ(d,"return")) return KEY_return;
4657 if (strEQ(d,"rename")) return -KEY_rename;
4658 if (strEQ(d,"rindex")) return -KEY_rindex;
4661 if (strEQ(d,"require")) return -KEY_require;
4662 if (strEQ(d,"reverse")) return -KEY_reverse;
4663 if (strEQ(d,"readdir")) return -KEY_readdir;
4666 if (strEQ(d,"readlink")) return -KEY_readlink;
4667 if (strEQ(d,"readline")) return -KEY_readline;
4668 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4671 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4677 case 0: return KEY_s;
4679 if (strEQ(d,"scalar")) return KEY_scalar;
4684 if (strEQ(d,"seek")) return -KEY_seek;
4685 if (strEQ(d,"send")) return -KEY_send;
4688 if (strEQ(d,"semop")) return -KEY_semop;
4691 if (strEQ(d,"select")) return -KEY_select;
4692 if (strEQ(d,"semctl")) return -KEY_semctl;
4693 if (strEQ(d,"semget")) return -KEY_semget;
4696 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4697 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4700 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4701 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4704 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4707 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4708 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4709 if (strEQ(d,"setservent")) return -KEY_setservent;
4712 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4713 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4720 if (strEQ(d,"shift")) return KEY_shift;
4723 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4724 if (strEQ(d,"shmget")) return -KEY_shmget;
4727 if (strEQ(d,"shmread")) return -KEY_shmread;
4730 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4731 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4736 if (strEQ(d,"sin")) return -KEY_sin;
4739 if (strEQ(d,"sleep")) return -KEY_sleep;
4742 if (strEQ(d,"sort")) return KEY_sort;
4743 if (strEQ(d,"socket")) return -KEY_socket;
4744 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4747 if (strEQ(d,"split")) return KEY_split;
4748 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4749 if (strEQ(d,"splice")) return KEY_splice;
4752 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4755 if (strEQ(d,"srand")) return -KEY_srand;
4758 if (strEQ(d,"stat")) return -KEY_stat;
4759 if (strEQ(d,"study")) return KEY_study;
4762 if (strEQ(d,"substr")) return -KEY_substr;
4763 if (strEQ(d,"sub")) return KEY_sub;
4768 if (strEQ(d,"system")) return -KEY_system;
4771 if (strEQ(d,"symlink")) return -KEY_symlink;
4772 if (strEQ(d,"syscall")) return -KEY_syscall;
4773 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4774 if (strEQ(d,"sysread")) return -KEY_sysread;
4775 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4778 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4787 if (strEQ(d,"tr")) return KEY_tr;
4790 if (strEQ(d,"tie")) return KEY_tie;
4793 if (strEQ(d,"tell")) return -KEY_tell;
4794 if (strEQ(d,"tied")) return KEY_tied;
4795 if (strEQ(d,"time")) return -KEY_time;
4798 if (strEQ(d,"times")) return -KEY_times;
4801 if (strEQ(d,"telldir")) return -KEY_telldir;
4804 if (strEQ(d,"truncate")) return -KEY_truncate;
4811 if (strEQ(d,"uc")) return -KEY_uc;
4814 if (strEQ(d,"use")) return KEY_use;
4817 if (strEQ(d,"undef")) return KEY_undef;
4818 if (strEQ(d,"until")) return KEY_until;
4819 if (strEQ(d,"untie")) return KEY_untie;
4820 if (strEQ(d,"utime")) return -KEY_utime;
4821 if (strEQ(d,"umask")) return -KEY_umask;
4824 if (strEQ(d,"unless")) return KEY_unless;
4825 if (strEQ(d,"unpack")) return -KEY_unpack;
4826 if (strEQ(d,"unlink")) return -KEY_unlink;
4829 if (strEQ(d,"unshift")) return KEY_unshift;
4830 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4835 if (strEQ(d,"values")) return -KEY_values;
4836 if (strEQ(d,"vec")) return -KEY_vec;
4841 if (strEQ(d,"warn")) return -KEY_warn;
4842 if (strEQ(d,"wait")) return -KEY_wait;
4845 if (strEQ(d,"while")) return KEY_while;
4846 if (strEQ(d,"write")) return -KEY_write;
4849 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4852 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4857 if (len == 1) return -KEY_x;
4858 if (strEQ(d,"xor")) return -KEY_xor;
4861 if (len == 1) return KEY_y;
4870 checkcomma(register char *s, char *name, char *what)
4874 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4875 dTHR; /* only for ckWARN */
4876 if (ckWARN(WARN_SYNTAX)) {
4878 for (w = s+2; *w && level; w++) {
4885 for (; *w && isSPACE(*w); w++) ;
4886 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4887 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4890 while (s < PL_bufend && isSPACE(*s))
4894 while (s < PL_bufend && isSPACE(*s))
4896 if (isIDFIRST(*s)) {
4900 while (s < PL_bufend && isSPACE(*s))
4905 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4909 croak("No comma allowed after %s", what);
4915 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4918 HV *table = GvHV(PL_hintgv); /* ^H */
4921 bool oldcatch = CATCH_GET;
4927 yyerror("%^H is not defined");
4930 cvp = hv_fetch(table, key, strlen(key), FALSE);
4931 if (!cvp || !SvOK(*cvp)) {
4932 sprintf(buf,"$^H{%s} is not defined", key);
4936 sv_2mortal(sv); /* Parent created it permanently */
4939 pv = sv_2mortal(newSVpv(s, len));
4941 typesv = sv_2mortal(newSVpv(type, 0));
4943 typesv = &PL_sv_undef;
4945 Zero(&myop, 1, BINOP);
4946 myop.op_last = (OP *) &myop;
4947 myop.op_next = Nullop;
4948 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4950 PUSHSTACKi(PERLSI_OVERLOAD);
4953 PL_op = (OP *) &myop;
4954 if (PERLDB_SUB && PL_curstash != PL_debstash)
4955 PL_op->op_private |= OPpENTERSUB_DB;
4966 if (PL_op = pp_entersub(ARGS))
4973 CATCH_SET(oldcatch);
4977 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4980 return SvREFCNT_inc(res);
4984 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4986 register char *d = dest;
4987 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4990 croak(ident_too_long);
4993 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4998 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5002 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
5003 char *t = s + UTF8SKIP(s);
5004 while (*t & 0x80 && is_utf8_mark((U8*)t))
5006 if (d + (t - s) > e)
5007 croak(ident_too_long);
5008 Copy(s, d, t - s, char);
5021 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5028 if (PL_lex_brackets == 0)
5029 PL_lex_fakebrack = 0;
5033 e = d + destlen - 3; /* two-character token, ending NUL */
5035 while (isDIGIT(*s)) {
5037 croak(ident_too_long);
5044 croak(ident_too_long);
5047 else if (*s == '\'' && isIDFIRST(s[1])) {
5052 else if (*s == ':' && s[1] == ':') {
5056 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
5057 char *t = s + UTF8SKIP(s);
5058 while (*t & 0x80 && is_utf8_mark((U8*)t))
5060 if (d + (t - s) > e)
5061 croak(ident_too_long);
5062 Copy(s, d, t - s, char);
5073 if (PL_lex_state != LEX_NORMAL)
5074 PL_lex_state = LEX_INTERPENDMAYBE;
5077 if (*s == '$' && s[1] &&
5078 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5091 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5096 if (isSPACE(s[-1])) {
5099 if (ch != ' ' && ch != '\t') {
5105 if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8((U8*)d))) {
5109 while (e < send && (isALNUM(*e) || ((*e & 0xc0) == 0x80 && isALNUM_utf8((U8*)e)) || *e == ':')) {
5111 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5114 Copy(s, d, e - s, char);
5119 while (isALNUM(*s) || *s == ':')
5123 while (s < send && (*s == ' ' || *s == '\t')) s++;
5124 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5125 dTHR; /* only for ckWARN */
5126 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5127 char *brack = *s == '[' ? "[...]" : "{...}";
5128 warner(WARN_AMBIGUOUS,
5129 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5130 funny, dest, brack, funny, dest, brack);
5132 PL_lex_fakebrack = PL_lex_brackets+1;
5134 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5140 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5141 PL_lex_state = LEX_INTERPEND;
5144 if (PL_lex_state == LEX_NORMAL) {
5145 dTHR; /* only for ckWARN */
5146 if (ckWARN(WARN_AMBIGUOUS) &&
5147 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5149 warner(WARN_AMBIGUOUS,
5150 "Ambiguous use of %c{%s} resolved to %c%s",
5151 funny, dest, funny, dest);
5156 s = bracket; /* let the parser handle it */
5160 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5161 PL_lex_state = LEX_INTERPEND;
5165 void pmflag(U16 *pmfl, int ch)
5170 *pmfl |= PMf_GLOBAL;
5172 *pmfl |= PMf_CONTINUE;
5176 *pmfl |= PMf_MULTILINE;
5178 *pmfl |= PMf_SINGLELINE;
5180 *pmfl |= PMf_EXTENDED;
5184 scan_pat(char *start, I32 type)
5189 s = scan_str(start);
5192 SvREFCNT_dec(PL_lex_stuff);
5193 PL_lex_stuff = Nullsv;
5194 croak("Search pattern not terminated");
5197 pm = (PMOP*)newPMOP(type, 0);
5198 if (PL_multi_open == '?')
5199 pm->op_pmflags |= PMf_ONCE;
5201 while (*s && strchr("iomsx", *s))
5202 pmflag(&pm->op_pmflags,*s++);
5205 while (*s && strchr("iogcmsx", *s))
5206 pmflag(&pm->op_pmflags,*s++);
5208 pm->op_pmpermflags = pm->op_pmflags;
5210 PL_lex_op = (OP*)pm;
5211 yylval.ival = OP_MATCH;
5216 scan_subst(char *start)
5223 yylval.ival = OP_NULL;
5225 s = scan_str(start);
5229 SvREFCNT_dec(PL_lex_stuff);
5230 PL_lex_stuff = Nullsv;
5231 croak("Substitution pattern not terminated");
5234 if (s[-1] == PL_multi_open)
5237 first_start = PL_multi_start;
5241 SvREFCNT_dec(PL_lex_stuff);
5242 PL_lex_stuff = Nullsv;
5244 SvREFCNT_dec(PL_lex_repl);
5245 PL_lex_repl = Nullsv;
5246 croak("Substitution replacement not terminated");
5248 PL_multi_start = first_start; /* so whole substitution is taken together */
5250 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5256 else if (strchr("iogcmsx", *s))
5257 pmflag(&pm->op_pmflags,*s++);
5264 pm->op_pmflags |= PMf_EVAL;
5265 repl = newSVpv("",0);
5267 sv_catpv(repl, es ? "eval " : "do ");
5268 sv_catpvn(repl, "{ ", 2);
5269 sv_catsv(repl, PL_lex_repl);
5270 sv_catpvn(repl, " };", 2);
5271 SvCOMPILED_on(repl);
5272 SvREFCNT_dec(PL_lex_repl);
5276 pm->op_pmpermflags = pm->op_pmflags;
5277 PL_lex_op = (OP*)pm;
5278 yylval.ival = OP_SUBST;
5283 scan_trans(char *start)
5294 yylval.ival = OP_NULL;
5296 s = scan_str(start);
5299 SvREFCNT_dec(PL_lex_stuff);
5300 PL_lex_stuff = Nullsv;
5301 croak("Transliteration pattern not terminated");
5303 if (s[-1] == PL_multi_open)
5309 SvREFCNT_dec(PL_lex_stuff);
5310 PL_lex_stuff = Nullsv;
5312 SvREFCNT_dec(PL_lex_repl);
5313 PL_lex_repl = Nullsv;
5314 croak("Transliteration replacement not terminated");
5318 o = newSVOP(OP_TRANS, 0, 0);
5319 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5322 New(803,tbl,256,short);
5323 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5327 complement = del = squash = 0;
5328 while (strchr("cdsCU", *s)) {
5330 complement = OPpTRANS_COMPLEMENT;
5332 del = OPpTRANS_DELETE;
5334 squash = OPpTRANS_SQUASH;
5339 utf8 &= ~OPpTRANS_FROM_UTF;
5341 utf8 |= OPpTRANS_FROM_UTF;
5345 utf8 &= ~OPpTRANS_TO_UTF;
5347 utf8 |= OPpTRANS_TO_UTF;
5350 croak("Too many /C and /U options");
5355 o->op_private = del|squash|complement|utf8;
5358 yylval.ival = OP_TRANS;
5363 scan_heredoc(register char *s)
5367 I32 op_type = OP_SCALAR;
5374 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5378 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5381 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5382 if (*peek && strchr("`'\"",*peek)) {
5385 s = delimcpy(d, e, s, PL_bufend, term, &len);
5396 deprecate("bare << to mean <<\"\"");
5397 for (; isALNUM(*s); s++) {
5402 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5403 croak("Delimiter for here document is too long");
5406 len = d - PL_tokenbuf;
5407 #ifndef PERL_STRICT_CR
5408 d = strchr(s, '\r');
5412 while (s < PL_bufend) {
5418 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5427 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5432 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5433 herewas = newSVpv(s,PL_bufend-s);
5435 s--, herewas = newSVpv(s,d-s);
5436 s += SvCUR(herewas);
5438 tmpstr = NEWSV(87,79);
5439 sv_upgrade(tmpstr, SVt_PVIV);
5444 else if (term == '`') {
5445 op_type = OP_BACKTICK;
5446 SvIVX(tmpstr) = '\\';
5450 PL_multi_start = PL_curcop->cop_line;
5451 PL_multi_open = PL_multi_close = '<';
5452 term = *PL_tokenbuf;
5455 while (s < PL_bufend &&
5456 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5458 PL_curcop->cop_line++;
5460 if (s >= PL_bufend) {
5461 PL_curcop->cop_line = PL_multi_start;
5462 missingterm(PL_tokenbuf);
5464 sv_setpvn(tmpstr,d+1,s-d);
5466 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5468 sv_catpvn(herewas,s,PL_bufend-s);
5469 sv_setsv(PL_linestr,herewas);
5470 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5471 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5474 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5475 while (s >= PL_bufend) { /* multiple line string? */
5477 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5478 PL_curcop->cop_line = PL_multi_start;
5479 missingterm(PL_tokenbuf);
5481 PL_curcop->cop_line++;
5482 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5483 #ifndef PERL_STRICT_CR
5484 if (PL_bufend - PL_linestart >= 2) {
5485 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5486 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5488 PL_bufend[-2] = '\n';
5490 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5492 else if (PL_bufend[-1] == '\r')
5493 PL_bufend[-1] = '\n';
5495 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5496 PL_bufend[-1] = '\n';
5498 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5499 SV *sv = NEWSV(88,0);
5501 sv_upgrade(sv, SVt_PVMG);
5502 sv_setsv(sv,PL_linestr);
5503 av_store(GvAV(PL_curcop->cop_filegv),
5504 (I32)PL_curcop->cop_line,sv);
5506 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5509 sv_catsv(PL_linestr,herewas);
5510 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5514 sv_catsv(tmpstr,PL_linestr);
5517 PL_multi_end = PL_curcop->cop_line;
5519 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5520 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5521 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5523 SvREFCNT_dec(herewas);
5524 PL_lex_stuff = tmpstr;
5525 yylval.ival = op_type;
5530 takes: current position in input buffer
5531 returns: new position in input buffer
5532 side-effects: yylval and lex_op are set.
5537 <FH> read from filehandle
5538 <pkg::FH> read from package qualified filehandle
5539 <pkg'FH> read from package qualified filehandle
5540 <$fh> read from filehandle in $fh
5546 scan_inputsymbol(char *start)
5548 register char *s = start; /* current position in buffer */
5553 d = PL_tokenbuf; /* start of temp holding space */
5554 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5555 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5557 /* die if we didn't have space for the contents of the <>,
5561 if (len >= sizeof PL_tokenbuf)
5562 croak("Excessively long <> operator");
5564 croak("Unterminated <> operator");
5569 Remember, only scalar variables are interpreted as filehandles by
5570 this code. Anything more complex (e.g., <$fh{$num}>) will be
5571 treated as a glob() call.
5572 This code makes use of the fact that except for the $ at the front,
5573 a scalar variable and a filehandle look the same.
5575 if (*d == '$' && d[1]) d++;
5577 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5578 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5581 /* If we've tried to read what we allow filehandles to look like, and
5582 there's still text left, then it must be a glob() and not a getline.
5583 Use scan_str to pull out the stuff between the <> and treat it
5584 as nothing more than a string.
5587 if (d - PL_tokenbuf != len) {
5588 yylval.ival = OP_GLOB;
5590 s = scan_str(start);
5592 croak("Glob not terminated");
5596 /* we're in a filehandle read situation */
5599 /* turn <> into <ARGV> */
5601 (void)strcpy(d,"ARGV");
5603 /* if <$fh>, create the ops to turn the variable into a
5609 /* try to find it in the pad for this block, otherwise find
5610 add symbol table ops
5612 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5613 OP *o = newOP(OP_PADSV, 0);
5615 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5618 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5619 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5620 newUNOP(OP_RV2GV, 0,
5621 newUNOP(OP_RV2SV, 0,
5622 newGVOP(OP_GV, 0, gv))));
5624 /* we created the ops in lex_op, so make yylval.ival a null op */
5625 yylval.ival = OP_NULL;
5628 /* If it's none of the above, it must be a literal filehandle
5629 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5631 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5632 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5633 yylval.ival = OP_NULL;
5642 takes: start position in buffer
5643 returns: position to continue reading from buffer
5644 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5645 updates the read buffer.
5647 This subroutine pulls a string out of the input. It is called for:
5648 q single quotes q(literal text)
5649 ' single quotes 'literal text'
5650 qq double quotes qq(interpolate $here please)
5651 " double quotes "interpolate $here please"
5652 qx backticks qx(/bin/ls -l)
5653 ` backticks `/bin/ls -l`
5654 qw quote words @EXPORT_OK = qw( func() $spam )
5655 m// regexp match m/this/
5656 s/// regexp substitute s/this/that/
5657 tr/// string transliterate tr/this/that/
5658 y/// string transliterate y/this/that/
5659 ($*@) sub prototypes sub foo ($)
5660 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5662 In most of these cases (all but <>, patterns and transliterate)
5663 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5664 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5665 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5668 It skips whitespace before the string starts, and treats the first
5669 character as the delimiter. If the delimiter is one of ([{< then
5670 the corresponding "close" character )]}> is used as the closing
5671 delimiter. It allows quoting of delimiters, and if the string has
5672 balanced delimiters ([{<>}]) it allows nesting.
5674 The lexer always reads these strings into lex_stuff, except in the
5675 case of the operators which take *two* arguments (s/// and tr///)
5676 when it checks to see if lex_stuff is full (presumably with the 1st
5677 arg to s or tr) and if so puts the string into lex_repl.
5682 scan_str(char *start)
5685 SV *sv; /* scalar value: string */
5686 char *tmps; /* temp string, used for delimiter matching */
5687 register char *s = start; /* current position in the buffer */
5688 register char term; /* terminating character */
5689 register char *to; /* current position in the sv's data */
5690 I32 brackets = 1; /* bracket nesting level */
5692 /* skip space before the delimiter */
5696 /* mark where we are, in case we need to report errors */
5699 /* after skipping whitespace, the next character is the terminator */
5701 /* mark where we are */
5702 PL_multi_start = PL_curcop->cop_line;
5703 PL_multi_open = term;
5705 /* find corresponding closing delimiter */
5706 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5708 PL_multi_close = term;
5710 /* create a new SV to hold the contents. 87 is leak category, I'm
5711 assuming. 79 is the SV's initial length. What a random number. */
5713 sv_upgrade(sv, SVt_PVIV);
5715 (void)SvPOK_only(sv); /* validate pointer */
5717 /* move past delimiter and try to read a complete string */
5720 /* extend sv if need be */
5721 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5722 /* set 'to' to the next character in the sv's string */
5723 to = SvPVX(sv)+SvCUR(sv);
5725 /* if open delimiter is the close delimiter read unbridle */
5726 if (PL_multi_open == PL_multi_close) {
5727 for (; s < PL_bufend; s++,to++) {
5728 /* embedded newlines increment the current line number */
5729 if (*s == '\n' && !PL_rsfp)
5730 PL_curcop->cop_line++;
5731 /* handle quoted delimiters */
5732 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5735 /* any other quotes are simply copied straight through */
5739 /* terminate when run out of buffer (the for() condition), or
5740 have found the terminator */
5741 else if (*s == term)
5747 /* if the terminator isn't the same as the start character (e.g.,
5748 matched brackets), we have to allow more in the quoting, and
5749 be prepared for nested brackets.
5752 /* read until we run out of string, or we find the terminator */
5753 for (; s < PL_bufend; s++,to++) {
5754 /* embedded newlines increment the line count */
5755 if (*s == '\n' && !PL_rsfp)
5756 PL_curcop->cop_line++;
5757 /* backslashes can escape the open or closing characters */
5758 if (*s == '\\' && s+1 < PL_bufend) {
5759 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5764 /* allow nested opens and closes */
5765 else if (*s == PL_multi_close && --brackets <= 0)
5767 else if (*s == PL_multi_open)
5772 /* terminate the copied string and update the sv's end-of-string */
5774 SvCUR_set(sv, to - SvPVX(sv));
5777 * this next chunk reads more into the buffer if we're not done yet
5780 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5782 #ifndef PERL_STRICT_CR
5783 if (to - SvPVX(sv) >= 2) {
5784 if ((to[-2] == '\r' && to[-1] == '\n') ||
5785 (to[-2] == '\n' && to[-1] == '\r'))
5789 SvCUR_set(sv, to - SvPVX(sv));
5791 else if (to[-1] == '\r')
5794 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5798 /* if we're out of file, or a read fails, bail and reset the current
5799 line marker so we can report where the unterminated string began
5802 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5804 PL_curcop->cop_line = PL_multi_start;
5807 /* we read a line, so increment our line counter */
5808 PL_curcop->cop_line++;
5810 /* update debugger info */
5811 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5812 SV *sv = NEWSV(88,0);
5814 sv_upgrade(sv, SVt_PVMG);
5815 sv_setsv(sv,PL_linestr);
5816 av_store(GvAV(PL_curcop->cop_filegv),
5817 (I32)PL_curcop->cop_line, sv);
5820 /* having changed the buffer, we must update PL_bufend */
5821 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5824 /* at this point, we have successfully read the delimited string */
5826 PL_multi_end = PL_curcop->cop_line;
5829 /* if we allocated too much space, give some back */
5830 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5831 SvLEN_set(sv, SvCUR(sv) + 1);
5832 Renew(SvPVX(sv), SvLEN(sv), char);
5835 /* decide whether this is the first or second quoted string we've read
5848 takes: pointer to position in buffer
5849 returns: pointer to new position in buffer
5850 side-effects: builds ops for the constant in yylval.op
5852 Read a number in any of the formats that Perl accepts:
5854 0(x[0-7A-F]+)|([0-7]+)
5855 [\d_]+(\.[\d_]*)?[Ee](\d+)
5857 Underbars (_) are allowed in decimal numbers. If -w is on,
5858 underbars before a decimal point must be at three digit intervals.
5860 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5863 If it reads a number without a decimal point or an exponent, it will
5864 try converting the number to an integer and see if it can do so
5865 without loss of precision.
5869 scan_num(char *start)
5871 register char *s = start; /* current position in buffer */
5872 register char *d; /* destination in temp buffer */
5873 register char *e; /* end of temp buffer */
5874 I32 tryiv; /* used to see if it can be an int */
5875 double value; /* number read, as a double */
5876 SV *sv; /* place to put the converted number */
5877 I32 floatit; /* boolean: int or float? */
5878 char *lastub = 0; /* position of last underbar */
5879 static char number_too_long[] = "Number too long";
5881 /* We use the first character to decide what type of number this is */
5885 croak("panic: scan_num");
5887 /* if it starts with a 0, it could be an octal number, a decimal in
5888 0.13 disguise, or a hexadecimal number.
5893 u holds the "number so far"
5894 shift the power of 2 of the base (hex == 4, octal == 3)
5895 overflowed was the number more than we can hold?
5897 Shift is used when we add a digit. It also serves as an "are
5898 we in octal or hex?" indicator to disallow hex characters when
5903 bool overflowed = FALSE;
5910 /* check for a decimal in disguise */
5911 else if (s[1] == '.')
5913 /* so it must be octal */
5918 /* read the rest of the octal number */
5920 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5924 /* if we don't mention it, we're done */
5933 /* 8 and 9 are not octal */
5936 yyerror("Illegal octal digit");
5940 case '0': case '1': case '2': case '3': case '4':
5941 case '5': case '6': case '7':
5942 b = *s++ & 15; /* ASCII digit -> value of digit */
5946 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5947 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5948 /* make sure they said 0x */
5953 /* Prepare to put the digit we have onto the end
5954 of the number so far. We check for overflows.
5958 n = u << shift; /* make room for the digit */
5959 if (!overflowed && (n >> shift) != u
5960 && !(PL_hints & HINT_NEW_BINARY)) {
5961 warn("Integer overflow in %s number",
5962 (shift == 4) ? "hex" : "octal");
5965 u = n | b; /* add the digit to the end */
5970 /* if we get here, we had success: make a scalar value from
5976 if ( PL_hints & HINT_NEW_BINARY)
5977 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5982 handle decimal numbers.
5983 we're also sent here when we read a 0 as the first digit
5985 case '1': case '2': case '3': case '4': case '5':
5986 case '6': case '7': case '8': case '9': case '.':
5989 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5992 /* read next group of digits and _ and copy into d */
5993 while (isDIGIT(*s) || *s == '_') {
5994 /* skip underscores, checking for misplaced ones
5998 dTHR; /* only for ckWARN */
5999 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6000 warner(WARN_SYNTAX, "Misplaced _ in number");
6004 /* check for end of fixed-length buffer */
6006 croak(number_too_long);
6007 /* if we're ok, copy the character */
6012 /* final misplaced underbar check */
6013 if (lastub && s - lastub != 3) {
6015 if (ckWARN(WARN_SYNTAX))
6016 warner(WARN_SYNTAX, "Misplaced _ in number");
6019 /* read a decimal portion if there is one. avoid
6020 3..5 being interpreted as the number 3. followed
6023 if (*s == '.' && s[1] != '.') {
6027 /* copy, ignoring underbars, until we run out of
6028 digits. Note: no misplaced underbar checks!
6030 for (; isDIGIT(*s) || *s == '_'; s++) {
6031 /* fixed length buffer check */
6033 croak(number_too_long);
6039 /* read exponent part, if present */
6040 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6044 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6045 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6047 /* allow positive or negative exponent */
6048 if (*s == '+' || *s == '-')
6051 /* read digits of exponent (no underbars :-) */
6052 while (isDIGIT(*s)) {
6054 croak(number_too_long);
6059 /* terminate the string */
6062 /* make an sv from the string */
6064 /* reset numeric locale in case we were earlier left in Swaziland */
6065 SET_NUMERIC_STANDARD();
6066 value = atof(PL_tokenbuf);
6069 See if we can make do with an integer value without loss of
6070 precision. We use I_V to cast to an int, because some
6071 compilers have issues. Then we try casting it back and see
6072 if it was the same. We only do this if we know we
6073 specifically read an integer.
6075 Note: if floatit is true, then we don't need to do the
6079 if (!floatit && (double)tryiv == value)
6080 sv_setiv(sv, tryiv);
6082 sv_setnv(sv, value);
6083 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6084 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6085 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6089 /* make the op for the constant and return */
6091 yylval.opval = newSVOP(OP_CONST, 0, sv);
6097 scan_formline(register char *s)
6102 SV *stuff = newSVpv("",0);
6103 bool needargs = FALSE;
6106 if (*s == '.' || *s == '}') {
6108 #ifdef PERL_STRICT_CR
6109 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6111 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6116 if (PL_in_eval && !PL_rsfp) {
6117 eol = strchr(s,'\n');
6122 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6124 for (t = s; t < eol; t++) {
6125 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6127 goto enough; /* ~~ must be first line in formline */
6129 if (*t == '@' || *t == '^')
6132 sv_catpvn(stuff, s, eol-s);
6136 s = filter_gets(PL_linestr, PL_rsfp, 0);
6137 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6138 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6141 yyerror("Format not terminated");
6151 PL_lex_state = LEX_NORMAL;
6152 PL_nextval[PL_nexttoke].ival = 0;
6156 PL_lex_state = LEX_FORMLINE;
6157 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6159 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6163 SvREFCNT_dec(stuff);
6164 PL_lex_formbrack = 0;
6175 PL_cshlen = strlen(PL_cshname);
6180 start_subparse(I32 is_format, U32 flags)
6183 I32 oldsavestack_ix = PL_savestack_ix;
6184 CV* outsidecv = PL_compcv;
6188 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6190 save_I32(&PL_subline);
6191 save_item(PL_subname);
6193 SAVESPTR(PL_curpad);
6194 SAVESPTR(PL_comppad);
6195 SAVESPTR(PL_comppad_name);
6196 SAVESPTR(PL_compcv);
6197 SAVEI32(PL_comppad_name_fill);
6198 SAVEI32(PL_min_intro_pending);
6199 SAVEI32(PL_max_intro_pending);
6200 SAVEI32(PL_pad_reset_pending);
6202 PL_compcv = (CV*)NEWSV(1104,0);
6203 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6204 CvFLAGS(PL_compcv) |= flags;
6206 PL_comppad = newAV();
6207 av_push(PL_comppad, Nullsv);
6208 PL_curpad = AvARRAY(PL_comppad);
6209 PL_comppad_name = newAV();
6210 PL_comppad_name_fill = 0;
6211 PL_min_intro_pending = 0;
6213 PL_subline = PL_curcop->cop_line;
6215 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6216 PL_curpad[0] = (SV*)newAV();
6217 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6218 #endif /* USE_THREADS */
6220 comppadlist = newAV();
6221 AvREAL_off(comppadlist);
6222 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6223 av_store(comppadlist, 1, (SV*)PL_comppad);
6225 CvPADLIST(PL_compcv) = comppadlist;
6226 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6228 CvOWNER(PL_compcv) = 0;
6229 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6230 MUTEX_INIT(CvMUTEXP(PL_compcv));
6231 #endif /* USE_THREADS */
6233 return oldsavestack_ix;
6252 char *context = NULL;
6256 if (!yychar || (yychar == ';' && !PL_rsfp))
6258 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6259 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6260 while (isSPACE(*PL_oldoldbufptr))
6262 context = PL_oldoldbufptr;
6263 contlen = PL_bufptr - PL_oldoldbufptr;
6265 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6266 PL_oldbufptr != PL_bufptr) {
6267 while (isSPACE(*PL_oldbufptr))
6269 context = PL_oldbufptr;
6270 contlen = PL_bufptr - PL_oldbufptr;
6272 else if (yychar > 255)
6273 where = "next token ???";
6274 else if ((yychar & 127) == 127) {
6275 if (PL_lex_state == LEX_NORMAL ||
6276 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6277 where = "at end of line";
6278 else if (PL_lex_inpat)
6279 where = "within pattern";
6281 where = "within string";
6284 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6286 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6287 else if (isPRINT_LC(yychar))
6288 sv_catpvf(where_sv, "%c", yychar);
6290 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6291 where = SvPVX(where_sv);
6293 msg = sv_2mortal(newSVpv(s, 0));
6294 sv_catpvf(msg, " at %_ line %ld, ",
6295 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6297 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6299 sv_catpvf(msg, "%s\n", where);
6300 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6302 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6303 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6308 else if (PL_in_eval)
6309 sv_catsv(ERRSV, msg);
6311 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6312 if (++PL_error_count >= 10)
6313 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6315 PL_in_my_stash = Nullhv;