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{}");
1085 if (ckWARN(WARN_UTF8))
1087 "Use of \\x{} without utf8 declaration");
1089 /* note: utf always shorter than hex */
1090 d = (char*)uv_to_utf8((U8*)d,
1091 scan_hex(s + 1, e - s - 1, &len));
1096 UV uv = (UV)scan_hex(s, 2, &len);
1097 if (utf && PL_lex_inwhat == OP_TRANS &&
1098 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1100 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1103 if (uv >= 127 && UTF) {
1105 if (ckWARN(WARN_UTF8))
1107 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1116 /* \c is a control character */
1130 /* printf-style backslashes, formfeeds, newlines, etc */
1156 } /* end if (backslash) */
1159 } /* while loop to process each character */
1161 /* terminate the string and set up the sv */
1163 SvCUR_set(sv, d - SvPVX(sv));
1166 /* shrink the sv if we allocated more than we used */
1167 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1168 SvLEN_set(sv, SvCUR(sv) + 1);
1169 Renew(SvPVX(sv), SvLEN(sv), char);
1172 /* return the substring (via yylval) only if we parsed anything */
1173 if (s > PL_bufptr) {
1174 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1175 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1177 ( PL_lex_inwhat == OP_TRANS
1179 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1182 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1188 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1190 intuit_more(register char *s)
1192 if (PL_lex_brackets)
1194 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1196 if (*s != '{' && *s != '[')
1201 /* In a pattern, so maybe we have {n,m}. */
1218 /* On the other hand, maybe we have a character class */
1221 if (*s == ']' || *s == '^')
1224 int weight = 2; /* let's weigh the evidence */
1226 unsigned char un_char = 255, last_un_char;
1227 char *send = strchr(s,']');
1228 char tmpbuf[sizeof PL_tokenbuf * 4];
1230 if (!send) /* has to be an expression */
1233 Zero(seen,256,char);
1236 else if (isDIGIT(*s)) {
1238 if (isDIGIT(s[1]) && s[2] == ']')
1244 for (; s < send; s++) {
1245 last_un_char = un_char;
1246 un_char = (unsigned char)*s;
1251 weight -= seen[un_char] * 10;
1252 if (isALNUM(s[1])) {
1253 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1254 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1259 else if (*s == '$' && s[1] &&
1260 strchr("[#!%*<>()-=",s[1])) {
1261 if (/*{*/ strchr("])} =",s[2]))
1270 if (strchr("wds]",s[1]))
1272 else if (seen['\''] || seen['"'])
1274 else if (strchr("rnftbxcav",s[1]))
1276 else if (isDIGIT(s[1])) {
1278 while (s[1] && isDIGIT(s[1]))
1288 if (strchr("aA01! ",last_un_char))
1290 if (strchr("zZ79~",s[1]))
1292 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1293 weight -= 5; /* cope with negative subscript */
1296 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1297 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1302 if (keyword(tmpbuf, d - tmpbuf))
1305 if (un_char == last_un_char + 1)
1307 weight -= seen[un_char];
1312 if (weight >= 0) /* probably a character class */
1320 intuit_method(char *start, GV *gv)
1322 char *s = start + (*start == '$');
1323 char tmpbuf[sizeof PL_tokenbuf];
1331 if ((cv = GvCVu(gv))) {
1332 char *proto = SvPVX(cv);
1342 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1343 if (*start == '$') {
1344 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1349 return *s == '(' ? FUNCMETH : METHOD;
1351 if (!keyword(tmpbuf, len)) {
1352 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1357 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1358 if (indirgv && GvCVu(indirgv))
1360 /* filehandle or package name makes it a method */
1361 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1363 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1364 return 0; /* no assumptions -- "=>" quotes bearword */
1366 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1368 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1372 return *s == '(' ? FUNCMETH : METHOD;
1382 char *pdb = PerlEnv_getenv("PERL5DB");
1386 SETERRNO(0,SS$_NORMAL);
1387 return "BEGIN { require 'perl5db.pl' }";
1393 /* Encoded script support. filter_add() effectively inserts a
1394 * 'pre-processing' function into the current source input stream.
1395 * Note that the filter function only applies to the current source file
1396 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1398 * The datasv parameter (which may be NULL) can be used to pass
1399 * private data to this instance of the filter. The filter function
1400 * can recover the SV using the FILTER_DATA macro and use it to
1401 * store private buffers and state information.
1403 * The supplied datasv parameter is upgraded to a PVIO type
1404 * and the IoDIRP field is used to store the function pointer.
1405 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1406 * private use must be set using malloc'd pointers.
1408 static int filter_debug = 0;
1411 filter_add(filter_t funcp, SV *datasv)
1413 if (!funcp){ /* temporary handy debugging hack to be deleted */
1414 filter_debug = atoi((char*)datasv);
1417 if (!PL_rsfp_filters)
1418 PL_rsfp_filters = newAV();
1420 datasv = NEWSV(255,0);
1421 if (!SvUPGRADE(datasv, SVt_PVIO))
1422 die("Can't upgrade filter_add data to SVt_PVIO");
1423 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1425 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1426 av_unshift(PL_rsfp_filters, 1);
1427 av_store(PL_rsfp_filters, 0, datasv) ;
1432 /* Delete most recently added instance of this filter function. */
1434 filter_del(filter_t funcp)
1437 warn("filter_del func %p", funcp);
1438 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1440 /* if filter is on top of stack (usual case) just pop it off */
1441 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1442 sv_free(av_pop(PL_rsfp_filters));
1446 /* we need to search for the correct entry and clear it */
1447 die("filter_del can only delete in reverse order (currently)");
1451 /* Invoke the n'th filter function for the current rsfp. */
1453 filter_read(int idx, SV *buf_sv, int maxlen)
1456 /* 0 = read one text line */
1461 if (!PL_rsfp_filters)
1463 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1464 /* Provide a default input filter to make life easy. */
1465 /* Note that we append to the line. This is handy. */
1467 warn("filter_read %d: from rsfp\n", idx);
1471 int old_len = SvCUR(buf_sv) ;
1473 /* ensure buf_sv is large enough */
1474 SvGROW(buf_sv, old_len + maxlen) ;
1475 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1476 if (PerlIO_error(PL_rsfp))
1477 return -1; /* error */
1479 return 0 ; /* end of file */
1481 SvCUR_set(buf_sv, old_len + len) ;
1484 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1485 if (PerlIO_error(PL_rsfp))
1486 return -1; /* error */
1488 return 0 ; /* end of file */
1491 return SvCUR(buf_sv);
1493 /* Skip this filter slot if filter has been deleted */
1494 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1496 warn("filter_read %d: skipped (filter deleted)\n", idx);
1497 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1499 /* Get function pointer hidden within datasv */
1500 funcp = (filter_t)IoDIRP(datasv);
1502 warn("filter_read %d: via function %p (%s)\n",
1503 idx, funcp, SvPV(datasv,PL_na));
1504 /* Call function. The function is expected to */
1505 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1506 /* Return: <0:error, =0:eof, >0:not eof */
1507 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1511 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1514 if (!PL_rsfp_filters) {
1515 filter_add(win32_textfilter,NULL);
1518 if (PL_rsfp_filters) {
1521 SvCUR_set(sv, 0); /* start with empty line */
1522 if (FILTER_READ(0, sv, 0) > 0)
1523 return ( SvPVX(sv) ) ;
1528 return (sv_gets(sv, fp, append));
1533 static char* exp_name[] =
1534 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1540 Works out what to call the token just pulled out of the input
1541 stream. The yacc parser takes care of taking the ops we return and
1542 stitching them into a tree.
1548 if read an identifier
1549 if we're in a my declaration
1550 croak if they tried to say my($foo::bar)
1551 build the ops for a my() declaration
1552 if it's an access to a my() variable
1553 are we in a sort block?
1554 croak if my($a); $a <=> $b
1555 build ops for access to a my() variable
1556 if in a dq string, and they've said @foo and we can't find @foo
1558 build ops for a bareword
1559 if we already built the token before, use it.
1573 /* check if there's an identifier for us to look at */
1574 if (PL_pending_ident) {
1575 /* pit holds the identifier we read and pending_ident is reset */
1576 char pit = PL_pending_ident;
1577 PL_pending_ident = 0;
1579 /* if we're in a my(), we can't allow dynamics here.
1580 $foo'bar has already been turned into $foo::bar, so
1581 just check for colons.
1583 if it's a legal name, the OP is a PADANY.
1586 if (strchr(PL_tokenbuf,':'))
1587 croak(no_myglob,PL_tokenbuf);
1589 yylval.opval = newOP(OP_PADANY, 0);
1590 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1595 build the ops for accesses to a my() variable.
1597 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1598 then used in a comparison. This catches most, but not
1599 all cases. For instance, it catches
1600 sort { my($a); $a <=> $b }
1602 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1603 (although why you'd do that is anyone's guess).
1606 if (!strchr(PL_tokenbuf,':')) {
1608 /* Check for single character per-thread SVs */
1609 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1610 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1611 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1613 yylval.opval = newOP(OP_THREADSV, 0);
1614 yylval.opval->op_targ = tmp;
1617 #endif /* USE_THREADS */
1618 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1619 /* if it's a sort block and they're naming $a or $b */
1620 if (PL_last_lop_op == OP_SORT &&
1621 PL_tokenbuf[0] == '$' &&
1622 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1625 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1626 d < PL_bufend && *d != '\n';
1629 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1630 croak("Can't use \"my %s\" in sort comparison",
1636 yylval.opval = newOP(OP_PADANY, 0);
1637 yylval.opval->op_targ = tmp;
1643 Whine if they've said @foo in a doublequoted string,
1644 and @foo isn't a variable we can find in the symbol
1647 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1648 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1649 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1650 yyerror(form("In string, %s now must be written as \\%s",
1651 PL_tokenbuf, PL_tokenbuf));
1654 /* build ops for a bareword */
1655 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1656 yylval.opval->op_private = OPpCONST_ENTERED;
1657 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1658 ((PL_tokenbuf[0] == '$') ? SVt_PV
1659 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1664 /* no identifier pending identification */
1666 switch (PL_lex_state) {
1668 case LEX_NORMAL: /* Some compilers will produce faster */
1669 case LEX_INTERPNORMAL: /* code if we comment these out. */
1673 /* when we're already built the next token, just pull it out the queue */
1676 yylval = PL_nextval[PL_nexttoke];
1678 PL_lex_state = PL_lex_defer;
1679 PL_expect = PL_lex_expect;
1680 PL_lex_defer = LEX_NORMAL;
1682 return(PL_nexttype[PL_nexttoke]);
1684 /* interpolated case modifiers like \L \U, including \Q and \E.
1685 when we get here, PL_bufptr is at the \
1687 case LEX_INTERPCASEMOD:
1689 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1690 croak("panic: INTERPCASEMOD");
1692 /* handle \E or end of string */
1693 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1697 if (PL_lex_casemods) {
1698 oldmod = PL_lex_casestack[--PL_lex_casemods];
1699 PL_lex_casestack[PL_lex_casemods] = '\0';
1701 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1703 PL_lex_state = LEX_INTERPCONCAT;
1707 if (PL_bufptr != PL_bufend)
1709 PL_lex_state = LEX_INTERPCONCAT;
1714 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1715 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1716 if (strchr("LU", *s) &&
1717 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1719 PL_lex_casestack[--PL_lex_casemods] = '\0';
1722 if (PL_lex_casemods > 10) {
1723 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1724 if (newlb != PL_lex_casestack) {
1726 PL_lex_casestack = newlb;
1729 PL_lex_casestack[PL_lex_casemods++] = *s;
1730 PL_lex_casestack[PL_lex_casemods] = '\0';
1731 PL_lex_state = LEX_INTERPCONCAT;
1732 PL_nextval[PL_nexttoke].ival = 0;
1735 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1737 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1739 PL_nextval[PL_nexttoke].ival = OP_LC;
1741 PL_nextval[PL_nexttoke].ival = OP_UC;
1743 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1745 croak("panic: yylex");
1748 if (PL_lex_starts) {
1757 case LEX_INTERPPUSH:
1758 return sublex_push();
1760 case LEX_INTERPSTART:
1761 if (PL_bufptr == PL_bufend)
1762 return sublex_done();
1764 PL_lex_dojoin = (*PL_bufptr == '@');
1765 PL_lex_state = LEX_INTERPNORMAL;
1766 if (PL_lex_dojoin) {
1767 PL_nextval[PL_nexttoke].ival = 0;
1770 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1771 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1772 force_next(PRIVATEREF);
1774 force_ident("\"", '$');
1775 #endif /* USE_THREADS */
1776 PL_nextval[PL_nexttoke].ival = 0;
1778 PL_nextval[PL_nexttoke].ival = 0;
1780 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1783 if (PL_lex_starts++) {
1789 case LEX_INTERPENDMAYBE:
1790 if (intuit_more(PL_bufptr)) {
1791 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1797 if (PL_lex_dojoin) {
1798 PL_lex_dojoin = FALSE;
1799 PL_lex_state = LEX_INTERPCONCAT;
1803 case LEX_INTERPCONCAT:
1805 if (PL_lex_brackets)
1806 croak("panic: INTERPCONCAT");
1808 if (PL_bufptr == PL_bufend)
1809 return sublex_done();
1811 if (SvIVX(PL_linestr) == '\'') {
1812 SV *sv = newSVsv(PL_linestr);
1815 else if ( PL_hints & HINT_NEW_RE )
1816 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1817 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1821 s = scan_const(PL_bufptr);
1823 PL_lex_state = LEX_INTERPCASEMOD;
1825 PL_lex_state = LEX_INTERPSTART;
1828 if (s != PL_bufptr) {
1829 PL_nextval[PL_nexttoke] = yylval;
1832 if (PL_lex_starts++)
1842 PL_lex_state = LEX_NORMAL;
1843 s = scan_formline(PL_bufptr);
1844 if (!PL_lex_formbrack)
1850 PL_oldoldbufptr = PL_oldbufptr;
1853 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1860 * Note: we try to be careful never to call the isXXX_utf8() functions unless we're
1861 * pretty sure we've seen the beginning of a UTF-8 character (that is, the two high
1862 * bits are set). Otherwise we risk loading in the heavy-duty SWASHINIT and SWASHGET
1863 * routines unnecessarily. You will see this not just here but throughout this file.
1865 if (UTF && (*s & 0xc0) == 0x80) {
1866 if (isIDFIRST_utf8((U8*)s))
1869 croak("Unrecognized character \\x%02X", *s & 255);
1872 goto fake_eof; /* emulate EOF on ^D or ^Z */
1877 if (PL_lex_brackets)
1878 yyerror("Missing right bracket");
1881 if (s++ < PL_bufend)
1882 goto retry; /* ignore stray nulls */
1885 if (!PL_in_eval && !PL_preambled) {
1886 PL_preambled = TRUE;
1887 sv_setpv(PL_linestr,incl_perldb());
1888 if (SvCUR(PL_linestr))
1889 sv_catpv(PL_linestr,";");
1891 while(AvFILLp(PL_preambleav) >= 0) {
1892 SV *tmpsv = av_shift(PL_preambleav);
1893 sv_catsv(PL_linestr, tmpsv);
1894 sv_catpv(PL_linestr, ";");
1897 sv_free((SV*)PL_preambleav);
1898 PL_preambleav = NULL;
1900 if (PL_minus_n || PL_minus_p) {
1901 sv_catpv(PL_linestr, "LINE: while (<>) {");
1903 sv_catpv(PL_linestr,"chomp;");
1905 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1907 GvIMPORTED_AV_on(gv);
1909 if (strchr("/'\"", *PL_splitstr)
1910 && strchr(PL_splitstr + 1, *PL_splitstr))
1911 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1914 s = "'~#\200\1'"; /* surely one char is unused...*/
1915 while (s[1] && strchr(PL_splitstr, *s)) s++;
1917 sv_catpvf(PL_linestr, "@F=split(%s%c",
1918 "q" + (delim == '\''), delim);
1919 for (s = PL_splitstr; *s; s++) {
1921 sv_catpvn(PL_linestr, "\\", 1);
1922 sv_catpvn(PL_linestr, s, 1);
1924 sv_catpvf(PL_linestr, "%c);", delim);
1928 sv_catpv(PL_linestr,"@F=split(' ');");
1931 sv_catpv(PL_linestr, "\n");
1932 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1933 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1934 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1935 SV *sv = NEWSV(85,0);
1937 sv_upgrade(sv, SVt_PVMG);
1938 sv_setsv(sv,PL_linestr);
1939 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1944 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1947 if (PL_preprocess && !PL_in_eval)
1948 (void)PerlProc_pclose(PL_rsfp);
1949 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1950 PerlIO_clearerr(PL_rsfp);
1952 (void)PerlIO_close(PL_rsfp);
1954 PL_doextract = FALSE;
1956 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1957 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1958 sv_catpv(PL_linestr,";}");
1959 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1960 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1961 PL_minus_n = PL_minus_p = 0;
1964 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1965 sv_setpv(PL_linestr,"");
1966 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1969 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1970 PL_doextract = FALSE;
1972 /* Incest with pod. */
1973 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1974 sv_setpv(PL_linestr, "");
1975 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1976 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1977 PL_doextract = FALSE;
1981 } while (PL_doextract);
1982 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1983 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1984 SV *sv = NEWSV(85,0);
1986 sv_upgrade(sv, SVt_PVMG);
1987 sv_setsv(sv,PL_linestr);
1988 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1990 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1991 if (PL_curcop->cop_line == 1) {
1992 while (s < PL_bufend && isSPACE(*s))
1994 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1998 if (*s == '#' && *(s+1) == '!')
2000 #ifdef ALTERNATE_SHEBANG
2002 static char as[] = ALTERNATE_SHEBANG;
2003 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2004 d = s + (sizeof(as) - 1);
2006 #endif /* ALTERNATE_SHEBANG */
2015 while (*d && !isSPACE(*d))
2019 #ifdef ARG_ZERO_IS_SCRIPT
2020 if (ipathend > ipath) {
2022 * HP-UX (at least) sets argv[0] to the script name,
2023 * which makes $^X incorrect. And Digital UNIX and Linux,
2024 * at least, set argv[0] to the basename of the Perl
2025 * interpreter. So, having found "#!", we'll set it right.
2027 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2028 assert(SvPOK(x) || SvGMAGICAL(x));
2029 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2030 sv_setpvn(x, ipath, ipathend - ipath);
2033 TAINT_NOT; /* $^X is always tainted, but that's OK */
2035 #endif /* ARG_ZERO_IS_SCRIPT */
2040 d = instr(s,"perl -");
2042 d = instr(s,"perl");
2043 #ifdef ALTERNATE_SHEBANG
2045 * If the ALTERNATE_SHEBANG on this system starts with a
2046 * character that can be part of a Perl expression, then if
2047 * we see it but not "perl", we're probably looking at the
2048 * start of Perl code, not a request to hand off to some
2049 * other interpreter. Similarly, if "perl" is there, but
2050 * not in the first 'word' of the line, we assume the line
2051 * contains the start of the Perl program.
2053 if (d && *s != '#') {
2055 while (*c && !strchr("; \t\r\n\f\v#", *c))
2058 d = Nullch; /* "perl" not in first word; ignore */
2060 *s = '#'; /* Don't try to parse shebang line */
2062 #endif /* ALTERNATE_SHEBANG */
2067 !instr(s,"indir") &&
2068 instr(PL_origargv[0],"perl"))
2074 while (s < PL_bufend && isSPACE(*s))
2076 if (s < PL_bufend) {
2077 Newz(899,newargv,PL_origargc+3,char*);
2079 while (s < PL_bufend && !isSPACE(*s))
2082 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2085 newargv = PL_origargv;
2087 execv(ipath, newargv);
2088 croak("Can't exec %s", ipath);
2091 U32 oldpdb = PL_perldb;
2092 bool oldn = PL_minus_n;
2093 bool oldp = PL_minus_p;
2095 while (*d && !isSPACE(*d)) d++;
2096 while (*d == ' ' || *d == '\t') d++;
2100 if (*d == 'M' || *d == 'm') {
2102 while (*d && !isSPACE(*d)) d++;
2103 croak("Too late for \"-%.*s\" option",
2106 d = moreswitches(d);
2108 if (PERLDB_LINE && !oldpdb ||
2109 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2110 /* if we have already added "LINE: while (<>) {",
2111 we must not do it again */
2113 sv_setpv(PL_linestr, "");
2114 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2115 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2116 PL_preambled = FALSE;
2118 (void)gv_fetchfile(PL_origfilename);
2125 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2127 PL_lex_state = LEX_FORMLINE;
2132 #ifdef PERL_STRICT_CR
2133 warn("Illegal character \\%03o (carriage return)", '\r');
2135 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2137 case ' ': case '\t': case '\f': case 013:
2142 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2144 while (s < d && *s != '\n')
2149 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2151 PL_lex_state = LEX_FORMLINE;
2161 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2166 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2169 if (strnEQ(s,"=>",2)) {
2170 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2171 OPERATOR('-'); /* unary minus */
2173 PL_last_uni = PL_oldbufptr;
2174 PL_last_lop_op = OP_FTEREAD; /* good enough */
2176 case 'r': FTST(OP_FTEREAD);
2177 case 'w': FTST(OP_FTEWRITE);
2178 case 'x': FTST(OP_FTEEXEC);
2179 case 'o': FTST(OP_FTEOWNED);
2180 case 'R': FTST(OP_FTRREAD);
2181 case 'W': FTST(OP_FTRWRITE);
2182 case 'X': FTST(OP_FTREXEC);
2183 case 'O': FTST(OP_FTROWNED);
2184 case 'e': FTST(OP_FTIS);
2185 case 'z': FTST(OP_FTZERO);
2186 case 's': FTST(OP_FTSIZE);
2187 case 'f': FTST(OP_FTFILE);
2188 case 'd': FTST(OP_FTDIR);
2189 case 'l': FTST(OP_FTLINK);
2190 case 'p': FTST(OP_FTPIPE);
2191 case 'S': FTST(OP_FTSOCK);
2192 case 'u': FTST(OP_FTSUID);
2193 case 'g': FTST(OP_FTSGID);
2194 case 'k': FTST(OP_FTSVTX);
2195 case 'b': FTST(OP_FTBLK);
2196 case 'c': FTST(OP_FTCHR);
2197 case 't': FTST(OP_FTTTY);
2198 case 'T': FTST(OP_FTTEXT);
2199 case 'B': FTST(OP_FTBINARY);
2200 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2201 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2202 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2204 croak("Unrecognized file test: -%c", (int)tmp);
2211 if (PL_expect == XOPERATOR)
2216 else if (*s == '>') {
2219 if (isIDFIRST(*s)) {
2220 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2228 if (PL_expect == XOPERATOR)
2231 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2233 OPERATOR('-'); /* unary minus */
2240 if (PL_expect == XOPERATOR)
2245 if (PL_expect == XOPERATOR)
2248 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2254 if (PL_expect != XOPERATOR) {
2255 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2256 PL_expect = XOPERATOR;
2257 force_ident(PL_tokenbuf, '*');
2270 if (PL_expect == XOPERATOR) {
2274 PL_tokenbuf[0] = '%';
2275 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2276 if (!PL_tokenbuf[1]) {
2278 yyerror("Final % should be \\% or %name");
2281 PL_pending_ident = '%';
2303 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2304 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2309 if (PL_curcop->cop_line < PL_copline)
2310 PL_copline = PL_curcop->cop_line;
2321 if (PL_lex_brackets <= 0)
2322 yyerror("Unmatched right bracket");
2325 if (PL_lex_state == LEX_INTERPNORMAL) {
2326 if (PL_lex_brackets == 0) {
2327 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2328 PL_lex_state = LEX_INTERPEND;
2335 if (PL_lex_brackets > 100) {
2336 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2337 if (newlb != PL_lex_brackstack) {
2339 PL_lex_brackstack = newlb;
2342 switch (PL_expect) {
2344 if (PL_lex_formbrack) {
2348 if (PL_oldoldbufptr == PL_last_lop)
2349 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2351 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2352 OPERATOR(HASHBRACK);
2354 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2357 PL_tokenbuf[0] = '\0';
2358 if (d < PL_bufend && *d == '-') {
2359 PL_tokenbuf[0] = '-';
2361 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2364 if (d < PL_bufend && isIDFIRST(*d)) {
2365 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2367 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2370 char minus = (PL_tokenbuf[0] == '-');
2371 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2378 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2382 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2387 if (PL_oldoldbufptr == PL_last_lop)
2388 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2390 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2393 OPERATOR(HASHBRACK);
2394 /* This hack serves to disambiguate a pair of curlies
2395 * as being a block or an anon hash. Normally, expectation
2396 * determines that, but in cases where we're not in a
2397 * position to expect anything in particular (like inside
2398 * eval"") we have to resolve the ambiguity. This code
2399 * covers the case where the first term in the curlies is a
2400 * quoted string. Most other cases need to be explicitly
2401 * disambiguated by prepending a `+' before the opening
2402 * curly in order to force resolution as an anon hash.
2404 * XXX should probably propagate the outer expectation
2405 * into eval"" to rely less on this hack, but that could
2406 * potentially break current behavior of eval"".
2410 if (*s == '\'' || *s == '"' || *s == '`') {
2411 /* common case: get past first string, handling escapes */
2412 for (t++; t < PL_bufend && *t != *s;)
2413 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2417 else if (*s == 'q') {
2420 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2421 && !isALNUM(*t)))) {
2423 char open, close, term;
2426 while (t < PL_bufend && isSPACE(*t))
2430 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2434 for (t++; t < PL_bufend; t++) {
2435 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2437 else if (*t == open)
2441 for (t++; t < PL_bufend; t++) {
2442 if (*t == '\\' && t+1 < PL_bufend)
2444 else if (*t == close && --brackets <= 0)
2446 else if (*t == open)
2452 else if (isALPHA(*s)) {
2453 for (t++; t < PL_bufend && isALNUM(*t); t++) ;
2455 while (t < PL_bufend && isSPACE(*t))
2457 /* if comma follows first term, call it an anon hash */
2458 /* XXX it could be a comma expression with loop modifiers */
2459 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2460 || (*t == '=' && t[1] == '>')))
2461 OPERATOR(HASHBRACK);
2462 if (PL_expect == XREF)
2465 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2471 yylval.ival = PL_curcop->cop_line;
2472 if (isSPACE(*s) || *s == '#')
2473 PL_copline = NOLINE; /* invalidate current command line number */
2478 if (PL_lex_brackets <= 0)
2479 yyerror("Unmatched right bracket");
2481 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2482 if (PL_lex_brackets < PL_lex_formbrack)
2483 PL_lex_formbrack = 0;
2484 if (PL_lex_state == LEX_INTERPNORMAL) {
2485 if (PL_lex_brackets == 0) {
2486 if (PL_lex_fakebrack) {
2487 PL_lex_state = LEX_INTERPEND;
2489 return yylex(); /* ignore fake brackets */
2491 if (*s == '-' && s[1] == '>')
2492 PL_lex_state = LEX_INTERPENDMAYBE;
2493 else if (*s != '[' && *s != '{')
2494 PL_lex_state = LEX_INTERPEND;
2497 if (PL_lex_brackets < PL_lex_fakebrack) {
2499 PL_lex_fakebrack = 0;
2500 return yylex(); /* ignore fake brackets */
2510 if (PL_expect == XOPERATOR) {
2511 if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && PL_bufptr == PL_linestart) {
2512 PL_curcop->cop_line--;
2513 warner(WARN_SEMICOLON, warn_nosemi);
2514 PL_curcop->cop_line++;
2519 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2521 PL_expect = XOPERATOR;
2522 force_ident(PL_tokenbuf, '&');
2526 yylval.ival = (OPpENTERSUB_AMPER<<8);
2545 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2546 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2548 if (PL_expect == XSTATE && isALPHA(tmp) &&
2549 (s == PL_linestart+1 || s[-2] == '\n') )
2551 if (PL_in_eval && !PL_rsfp) {
2556 if (strnEQ(s,"=cut",4)) {
2570 PL_doextract = TRUE;
2573 if (PL_lex_brackets < PL_lex_formbrack) {
2575 #ifdef PERL_STRICT_CR
2576 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2578 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2580 if (*t == '\n' || *t == '#') {
2598 if (PL_expect != XOPERATOR) {
2599 if (s[1] != '<' && !strchr(s,'>'))
2602 s = scan_heredoc(s);
2604 s = scan_inputsymbol(s);
2605 TERM(sublex_start());
2610 SHop(OP_LEFT_SHIFT);
2624 SHop(OP_RIGHT_SHIFT);
2633 if (PL_expect == XOPERATOR) {
2634 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2637 return ','; /* grandfather non-comma-format format */
2641 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:+-", s[2]))) {
2642 if (PL_expect == XOPERATOR)
2643 no_op("Array length", PL_bufptr);
2644 PL_tokenbuf[0] = '@';
2645 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2647 if (!PL_tokenbuf[1])
2649 PL_expect = XOPERATOR;
2650 PL_pending_ident = '#';
2654 if (PL_expect == XOPERATOR)
2655 no_op("Scalar", PL_bufptr);
2656 PL_tokenbuf[0] = '$';
2657 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2658 if (!PL_tokenbuf[1]) {
2660 yyerror("Final $ should be \\$ or $name");
2664 /* This kludge not intended to be bulletproof. */
2665 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2666 yylval.opval = newSVOP(OP_CONST, 0,
2667 newSViv((IV)PL_compiling.cop_arybase));
2668 yylval.opval->op_private = OPpCONST_ARYBASE;
2673 if (PL_lex_state == LEX_NORMAL)
2676 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2679 PL_tokenbuf[0] = '@';
2680 if (ckWARN(WARN_SYNTAX)) {
2682 isSPACE(*t) || isALNUM(*t) || *t == '$';
2685 PL_bufptr = skipspace(PL_bufptr);
2686 while (t < PL_bufend && *t != ']')
2689 "Multidimensional syntax %.*s not supported",
2690 (t - PL_bufptr) + 1, PL_bufptr);
2694 else if (*s == '{') {
2695 PL_tokenbuf[0] = '%';
2696 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2697 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2699 char tmpbuf[sizeof PL_tokenbuf];
2701 for (t++; isSPACE(*t); t++) ;
2702 if (isIDFIRST(*t)) {
2703 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2704 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2706 "You need to quote \"%s\"", tmpbuf);
2712 PL_expect = XOPERATOR;
2713 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2714 bool islop = (PL_last_lop == PL_oldoldbufptr);
2715 if (!islop || PL_last_lop_op == OP_GREPSTART)
2716 PL_expect = XOPERATOR;
2717 else if (strchr("$@\"'`q", *s))
2718 PL_expect = XTERM; /* e.g. print $fh "foo" */
2719 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2720 PL_expect = XTERM; /* e.g. print $fh &sub */
2721 else if (isIDFIRST(*s)) {
2722 char tmpbuf[sizeof PL_tokenbuf];
2723 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2724 if (tmp = keyword(tmpbuf, len)) {
2725 /* binary operators exclude handle interpretations */
2737 PL_expect = XTERM; /* e.g. print $fh length() */
2742 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2743 if (gv && GvCVu(gv))
2744 PL_expect = XTERM; /* e.g. print $fh subr() */
2747 else if (isDIGIT(*s))
2748 PL_expect = XTERM; /* e.g. print $fh 3 */
2749 else if (*s == '.' && isDIGIT(s[1]))
2750 PL_expect = XTERM; /* e.g. print $fh .3 */
2751 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2752 PL_expect = XTERM; /* e.g. print $fh -1 */
2753 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2754 PL_expect = XTERM; /* print $fh <<"EOF" */
2756 PL_pending_ident = '$';
2760 if (PL_expect == XOPERATOR)
2762 PL_tokenbuf[0] = '@';
2763 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2764 if (!PL_tokenbuf[1]) {
2766 yyerror("Final @ should be \\@ or @name");
2769 if (PL_lex_state == LEX_NORMAL)
2771 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2773 PL_tokenbuf[0] = '%';
2775 /* Warn about @ where they meant $. */
2776 if (ckWARN(WARN_SYNTAX)) {
2777 if (*s == '[' || *s == '{') {
2779 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2781 if (*t == '}' || *t == ']') {
2783 PL_bufptr = skipspace(PL_bufptr);
2785 "Scalar value %.*s better written as $%.*s",
2786 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2791 PL_pending_ident = '@';
2794 case '/': /* may either be division or pattern */
2795 case '?': /* may either be conditional or pattern */
2796 if (PL_expect != XOPERATOR) {
2797 /* Disable warning on "study /blah/" */
2798 if (PL_oldoldbufptr == PL_last_uni
2799 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2800 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2802 s = scan_pat(s,OP_MATCH);
2803 TERM(sublex_start());
2811 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2812 #ifdef PERL_STRICT_CR
2815 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2817 && (s == PL_linestart || s[-1] == '\n') )
2819 PL_lex_formbrack = 0;
2823 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2829 yylval.ival = OPf_SPECIAL;
2835 if (PL_expect != XOPERATOR)
2840 case '0': case '1': case '2': case '3': case '4':
2841 case '5': case '6': case '7': case '8': case '9':
2843 if (PL_expect == XOPERATOR)
2849 if (PL_expect == XOPERATOR) {
2850 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2853 return ','; /* grandfather non-comma-format format */
2859 missingterm((char*)0);
2860 yylval.ival = OP_CONST;
2861 TERM(sublex_start());
2865 if (PL_expect == XOPERATOR) {
2866 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2869 return ','; /* grandfather non-comma-format format */
2875 missingterm((char*)0);
2876 yylval.ival = OP_CONST;
2877 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2878 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2879 yylval.ival = OP_STRINGIFY;
2883 TERM(sublex_start());
2887 if (PL_expect == XOPERATOR)
2888 no_op("Backticks",s);
2890 missingterm((char*)0);
2891 yylval.ival = OP_BACKTICK;
2893 TERM(sublex_start());
2897 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2898 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2900 if (PL_expect == XOPERATOR)
2901 no_op("Backslash",s);
2905 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2944 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2946 /* Some keywords can be followed by any delimiter, including ':' */
2947 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2948 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2949 (PL_tokenbuf[0] == 'q' &&
2950 strchr("qwxr", PL_tokenbuf[1]))));
2952 /* x::* is just a word, unless x is "CORE" */
2953 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2957 while (d < PL_bufend && isSPACE(*d))
2958 d++; /* no comments skipped here, or s### is misparsed */
2960 /* Is this a label? */
2961 if (!tmp && PL_expect == XSTATE
2962 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2964 yylval.pval = savepv(PL_tokenbuf);
2969 /* Check for keywords */
2970 tmp = keyword(PL_tokenbuf, len);
2972 /* Is this a word before a => operator? */
2973 if (strnEQ(d,"=>",2)) {
2975 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2976 yylval.opval->op_private = OPpCONST_BARE;
2980 if (tmp < 0) { /* second-class keyword? */
2981 GV *ogv = Nullgv; /* override (winner) */
2982 GV *hgv = Nullgv; /* hidden (loser) */
2983 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2985 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
2988 if (GvIMPORTED_CV(gv))
2990 else if (! CvMETHOD(cv))
2994 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2995 (gv = *gvp) != (GV*)&PL_sv_undef &&
2996 GvCVu(gv) && GvIMPORTED_CV(gv))
3002 tmp = 0; /* overridden by import or by GLOBAL */
3005 && -tmp==KEY_lock /* XXX generalizable kludge */
3006 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3008 tmp = 0; /* any sub overrides "weak" keyword */
3010 else { /* no override */
3014 if (ckWARN(WARN_AMBIGUOUS) && hgv
3015 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3016 warner(WARN_AMBIGUOUS,
3017 "Ambiguous call resolved as CORE::%s(), %s",
3018 GvENAME(hgv), "qualify as such or use &");
3025 default: /* not a keyword */
3028 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3030 /* Get the rest if it looks like a package qualifier */
3032 if (*s == '\'' || *s == ':' && s[1] == ':') {
3034 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3037 croak("Bad name after %s%s", PL_tokenbuf,
3038 *s == '\'' ? "'" : "::");
3042 if (PL_expect == XOPERATOR) {
3043 if (PL_bufptr == PL_linestart) {
3044 PL_curcop->cop_line--;
3045 warner(WARN_SEMICOLON, warn_nosemi);
3046 PL_curcop->cop_line++;
3049 no_op("Bareword",s);
3052 /* Look for a subroutine with this name in current package,
3053 unless name is "Foo::", in which case Foo is a bearword
3054 (and a package name). */
3057 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3059 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3061 "Bareword \"%s\" refers to nonexistent package",
3064 PL_tokenbuf[len] = '\0';
3071 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3074 /* if we saw a global override before, get the right name */
3077 sv = newSVpv("CORE::GLOBAL::",14);
3078 sv_catpv(sv,PL_tokenbuf);
3081 sv = newSVpv(PL_tokenbuf,0);
3083 /* Presume this is going to be a bareword of some sort. */
3086 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3087 yylval.opval->op_private = OPpCONST_BARE;
3089 /* And if "Foo::", then that's what it certainly is. */
3094 /* See if it's the indirect object for a list operator. */
3096 if (PL_oldoldbufptr &&
3097 PL_oldoldbufptr < PL_bufptr &&
3098 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3099 /* NO SKIPSPACE BEFORE HERE! */
3101 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3102 || (PL_last_lop_op == OP_ENTERSUB
3104 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3106 bool immediate_paren = *s == '(';
3108 /* (Now we can afford to cross potential line boundary.) */
3111 /* Two barewords in a row may indicate method call. */
3113 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
3116 /* If not a declared subroutine, it's an indirect object. */
3117 /* (But it's an indir obj regardless for sort.) */
3119 if ((PL_last_lop_op == OP_SORT ||
3120 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3121 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3122 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3127 /* If followed by a paren, it's certainly a subroutine. */
3129 PL_expect = XOPERATOR;
3133 if (gv && GvCVu(gv)) {
3134 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3135 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3140 PL_nextval[PL_nexttoke].opval = yylval.opval;
3141 PL_expect = XOPERATOR;
3147 /* If followed by var or block, call it a method (unless sub) */
3149 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3150 PL_last_lop = PL_oldbufptr;
3151 PL_last_lop_op = OP_METHOD;
3155 /* If followed by a bareword, see if it looks like indir obj. */
3157 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3160 /* Not a method, so call it a subroutine (if defined) */
3162 if (gv && GvCVu(gv)) {
3164 if (lastchar == '-')
3165 warn("Ambiguous use of -%s resolved as -&%s()",
3166 PL_tokenbuf, PL_tokenbuf);
3167 PL_last_lop = PL_oldbufptr;
3168 PL_last_lop_op = OP_ENTERSUB;
3169 /* Check for a constant sub */
3171 if ((sv = cv_const_sv(cv))) {
3173 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3174 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3175 yylval.opval->op_private = 0;
3179 /* Resolve to GV now. */
3180 op_free(yylval.opval);
3181 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3182 /* Is there a prototype? */
3185 PL_last_proto = SvPV((SV*)cv, len);
3188 if (strEQ(PL_last_proto, "$"))
3190 if (*PL_last_proto == '&' && *s == '{') {
3191 sv_setpv(PL_subname,"__ANON__");
3195 PL_last_proto = NULL;
3196 PL_nextval[PL_nexttoke].opval = yylval.opval;
3202 if (PL_hints & HINT_STRICT_SUBS &&
3205 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3206 PL_last_lop_op != OP_ACCEPT &&
3207 PL_last_lop_op != OP_PIPE_OP &&
3208 PL_last_lop_op != OP_SOCKPAIR)
3211 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3216 /* Call it a bare word */
3219 if (ckWARN(WARN_RESERVED)) {
3220 if (lastchar != '-') {
3221 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3223 warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
3228 if (lastchar && strchr("*%&", lastchar)) {
3229 warn("Operator or semicolon missing before %c%s",
3230 lastchar, PL_tokenbuf);
3231 warn("Ambiguous use of %c resolved as operator %c",
3232 lastchar, lastchar);
3238 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3239 newSVsv(GvSV(PL_curcop->cop_filegv)));
3243 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3244 newSVpvf("%ld", (long)PL_curcop->cop_line));
3247 case KEY___PACKAGE__:
3248 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3250 ? newSVsv(PL_curstname)
3259 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3260 char *pname = "main";
3261 if (PL_tokenbuf[2] == 'D')
3262 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3263 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3266 GvIOp(gv) = newIO();
3267 IoIFP(GvIOp(gv)) = PL_rsfp;
3268 #if defined(HAS_FCNTL) && defined(F_SETFD)
3270 int fd = PerlIO_fileno(PL_rsfp);
3271 fcntl(fd,F_SETFD,fd >= 3);
3274 /* Mark this internal pseudo-handle as clean */
3275 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3277 IoTYPE(GvIOp(gv)) = '|';
3278 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3279 IoTYPE(GvIOp(gv)) = '-';
3281 IoTYPE(GvIOp(gv)) = '<';
3292 if (PL_expect == XSTATE) {
3299 if (*s == ':' && s[1] == ':') {
3302 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3303 tmp = keyword(PL_tokenbuf, len);
3317 LOP(OP_ACCEPT,XTERM);
3323 LOP(OP_ATAN2,XTERM);
3332 LOP(OP_BLESS,XTERM);
3341 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3358 if (!PL_cryptseen++)
3361 LOP(OP_CRYPT,XTERM);
3364 if (ckWARN(WARN_OCTAL)) {
3365 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3366 if (*d != '0' && isDIGIT(*d))
3367 yywarn("chmod: mode argument is missing initial 0");
3369 LOP(OP_CHMOD,XTERM);
3372 LOP(OP_CHOWN,XTERM);
3375 LOP(OP_CONNECT,XTERM);
3391 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3395 PL_hints |= HINT_BLOCK_SCOPE;
3405 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3406 LOP(OP_DBMOPEN,XTERM);
3412 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3419 yylval.ival = PL_curcop->cop_line;
3433 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3434 UNIBRACK(OP_ENTEREVAL);
3449 case KEY_endhostent:
3455 case KEY_endservent:
3458 case KEY_endprotoent:
3469 yylval.ival = PL_curcop->cop_line;
3471 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3473 if ((PL_bufend - p) >= 3 &&
3474 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3478 croak("Missing $ on loop variable");
3483 LOP(OP_FORMLINE,XTERM);
3489 LOP(OP_FCNTL,XTERM);
3495 LOP(OP_FLOCK,XTERM);
3504 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3507 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3522 case KEY_getpriority:
3523 LOP(OP_GETPRIORITY,XTERM);
3525 case KEY_getprotobyname:
3528 case KEY_getprotobynumber:
3529 LOP(OP_GPBYNUMBER,XTERM);
3531 case KEY_getprotoent:
3543 case KEY_getpeername:
3544 UNI(OP_GETPEERNAME);
3546 case KEY_gethostbyname:
3549 case KEY_gethostbyaddr:
3550 LOP(OP_GHBYADDR,XTERM);
3552 case KEY_gethostent:
3555 case KEY_getnetbyname:
3558 case KEY_getnetbyaddr:
3559 LOP(OP_GNBYADDR,XTERM);
3564 case KEY_getservbyname:
3565 LOP(OP_GSBYNAME,XTERM);
3567 case KEY_getservbyport:
3568 LOP(OP_GSBYPORT,XTERM);
3570 case KEY_getservent:
3573 case KEY_getsockname:
3574 UNI(OP_GETSOCKNAME);
3576 case KEY_getsockopt:
3577 LOP(OP_GSOCKOPT,XTERM);
3599 yylval.ival = PL_curcop->cop_line;
3603 LOP(OP_INDEX,XTERM);
3609 LOP(OP_IOCTL,XTERM);
3621 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3652 LOP(OP_LISTEN,XTERM);
3661 s = scan_pat(s,OP_MATCH);
3662 TERM(sublex_start());
3665 LOP(OP_MAPSTART,XREF);
3668 LOP(OP_MKDIR,XTERM);
3671 LOP(OP_MSGCTL,XTERM);
3674 LOP(OP_MSGGET,XTERM);
3677 LOP(OP_MSGRCV,XTERM);
3680 LOP(OP_MSGSND,XTERM);
3685 if (isIDFIRST(*s)) {
3686 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3687 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3688 if (!PL_in_my_stash) {
3691 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3698 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3705 if (PL_expect != XSTATE)
3706 yyerror("\"no\" not allowed in expression");
3707 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3708 s = force_version(s);
3717 if (isIDFIRST(*s)) {
3719 for (d = s; isALNUM(*d); d++) ;
3721 if (strchr("|&*+-=!?:.", *t))
3722 warn("Precedence problem: open %.*s should be open(%.*s)",
3728 yylval.ival = OP_OR;
3738 LOP(OP_OPEN_DIR,XTERM);
3741 checkcomma(s,PL_tokenbuf,"filehandle");
3745 checkcomma(s,PL_tokenbuf,"filehandle");
3764 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3768 LOP(OP_PIPE_OP,XTERM);
3773 missingterm((char*)0);
3774 yylval.ival = OP_CONST;
3775 TERM(sublex_start());
3783 missingterm((char*)0);
3784 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3785 d = SvPV_force(PL_lex_stuff, len);
3786 for (; len; --len, ++d) {
3789 "Possible attempt to separate words with commas");
3794 "Possible attempt to put comments in qw() list");
3800 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3801 PL_lex_stuff = Nullsv;
3804 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3807 yylval.ival = OP_SPLIT;
3811 PL_last_lop = PL_oldbufptr;
3812 PL_last_lop_op = OP_SPLIT;
3818 missingterm((char*)0);
3819 yylval.ival = OP_STRINGIFY;
3820 if (SvIVX(PL_lex_stuff) == '\'')
3821 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3822 TERM(sublex_start());
3825 s = scan_pat(s,OP_QR);
3826 TERM(sublex_start());
3831 missingterm((char*)0);
3832 yylval.ival = OP_BACKTICK;
3834 TERM(sublex_start());
3840 *PL_tokenbuf = '\0';
3841 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3842 if (isIDFIRST(*PL_tokenbuf))
3843 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3845 yyerror("<> should be quotes");
3852 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3856 LOP(OP_RENAME,XTERM);
3865 LOP(OP_RINDEX,XTERM);
3888 LOP(OP_REVERSE,XTERM);
3899 TERM(sublex_start());
3901 TOKEN(1); /* force error */
3910 LOP(OP_SELECT,XTERM);
3916 LOP(OP_SEMCTL,XTERM);
3919 LOP(OP_SEMGET,XTERM);
3922 LOP(OP_SEMOP,XTERM);
3928 LOP(OP_SETPGRP,XTERM);
3930 case KEY_setpriority:
3931 LOP(OP_SETPRIORITY,XTERM);
3933 case KEY_sethostent:
3939 case KEY_setservent:
3942 case KEY_setprotoent:
3952 LOP(OP_SEEKDIR,XTERM);
3954 case KEY_setsockopt:
3955 LOP(OP_SSOCKOPT,XTERM);
3961 LOP(OP_SHMCTL,XTERM);
3964 LOP(OP_SHMGET,XTERM);
3967 LOP(OP_SHMREAD,XTERM);
3970 LOP(OP_SHMWRITE,XTERM);
3973 LOP(OP_SHUTDOWN,XTERM);
3982 LOP(OP_SOCKET,XTERM);
3984 case KEY_socketpair:
3985 LOP(OP_SOCKPAIR,XTERM);
3988 checkcomma(s,PL_tokenbuf,"subroutine name");
3990 if (*s == ';' || *s == ')') /* probably a close */
3991 croak("sort is now a reserved word");
3993 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3997 LOP(OP_SPLIT,XTERM);
4000 LOP(OP_SPRINTF,XTERM);
4003 LOP(OP_SPLICE,XTERM);
4019 LOP(OP_SUBSTR,XTERM);
4026 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
4027 char tmpbuf[sizeof PL_tokenbuf];
4029 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4030 if (strchr(tmpbuf, ':'))
4031 sv_setpv(PL_subname, tmpbuf);
4033 sv_setsv(PL_subname,PL_curstname);
4034 sv_catpvn(PL_subname,"::",2);
4035 sv_catpvn(PL_subname,tmpbuf,len);
4037 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4041 PL_expect = XTERMBLOCK;
4042 sv_setpv(PL_subname,"?");
4045 if (tmp == KEY_format) {
4048 PL_lex_formbrack = PL_lex_brackets + 1;
4052 /* Look for a prototype */
4059 SvREFCNT_dec(PL_lex_stuff);
4060 PL_lex_stuff = Nullsv;
4061 croak("Prototype not terminated");
4064 d = SvPVX(PL_lex_stuff);
4066 for (p = d; *p; ++p) {
4071 SvCUR(PL_lex_stuff) = tmp;
4074 PL_nextval[1] = PL_nextval[0];
4075 PL_nexttype[1] = PL_nexttype[0];
4076 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4077 PL_nexttype[0] = THING;
4078 if (PL_nexttoke == 1) {
4079 PL_lex_defer = PL_lex_state;
4080 PL_lex_expect = PL_expect;
4081 PL_lex_state = LEX_KNOWNEXT;
4083 PL_lex_stuff = Nullsv;
4086 if (*SvPV(PL_subname,PL_na) == '?') {
4087 sv_setpv(PL_subname,"__ANON__");
4094 LOP(OP_SYSTEM,XREF);
4097 LOP(OP_SYMLINK,XTERM);
4100 LOP(OP_SYSCALL,XTERM);
4103 LOP(OP_SYSOPEN,XTERM);
4106 LOP(OP_SYSSEEK,XTERM);
4109 LOP(OP_SYSREAD,XTERM);
4112 LOP(OP_SYSWRITE,XTERM);
4116 TERM(sublex_start());
4137 LOP(OP_TRUNCATE,XTERM);
4149 yylval.ival = PL_curcop->cop_line;
4153 yylval.ival = PL_curcop->cop_line;
4157 LOP(OP_UNLINK,XTERM);
4163 LOP(OP_UNPACK,XTERM);
4166 LOP(OP_UTIME,XTERM);
4169 if (ckWARN(WARN_OCTAL)) {
4170 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4171 if (*d != '0' && isDIGIT(*d))
4172 yywarn("umask: argument is missing initial 0");
4177 LOP(OP_UNSHIFT,XTERM);
4180 if (PL_expect != XSTATE)
4181 yyerror("\"use\" not allowed in expression");
4184 s = force_version(s);
4185 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4186 PL_nextval[PL_nexttoke].opval = Nullop;
4191 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4192 s = force_version(s);
4205 yylval.ival = PL_curcop->cop_line;
4209 PL_hints |= HINT_BLOCK_SCOPE;
4216 LOP(OP_WAITPID,XTERM);
4224 static char ctl_l[2];
4226 if (ctl_l[0] == '\0')
4227 ctl_l[0] = toCTRL('L');
4228 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4231 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4236 if (PL_expect == XOPERATOR)
4242 yylval.ival = OP_XOR;
4247 TERM(sublex_start());
4253 keyword(register char *d, I32 len)
4258 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4259 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4260 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4261 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4262 if (strEQ(d,"__END__")) return KEY___END__;
4266 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4271 if (strEQ(d,"and")) return -KEY_and;
4272 if (strEQ(d,"abs")) return -KEY_abs;
4275 if (strEQ(d,"alarm")) return -KEY_alarm;
4276 if (strEQ(d,"atan2")) return -KEY_atan2;
4279 if (strEQ(d,"accept")) return -KEY_accept;
4284 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4287 if (strEQ(d,"bless")) return -KEY_bless;
4288 if (strEQ(d,"bind")) return -KEY_bind;
4289 if (strEQ(d,"binmode")) return -KEY_binmode;
4292 if (strEQ(d,"CORE")) return -KEY_CORE;
4297 if (strEQ(d,"cmp")) return -KEY_cmp;
4298 if (strEQ(d,"chr")) return -KEY_chr;
4299 if (strEQ(d,"cos")) return -KEY_cos;
4302 if (strEQ(d,"chop")) return KEY_chop;
4305 if (strEQ(d,"close")) return -KEY_close;
4306 if (strEQ(d,"chdir")) return -KEY_chdir;
4307 if (strEQ(d,"chomp")) return KEY_chomp;
4308 if (strEQ(d,"chmod")) return -KEY_chmod;
4309 if (strEQ(d,"chown")) return -KEY_chown;
4310 if (strEQ(d,"crypt")) return -KEY_crypt;
4313 if (strEQ(d,"chroot")) return -KEY_chroot;
4314 if (strEQ(d,"caller")) return -KEY_caller;
4317 if (strEQ(d,"connect")) return -KEY_connect;
4320 if (strEQ(d,"closedir")) return -KEY_closedir;
4321 if (strEQ(d,"continue")) return -KEY_continue;
4326 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4331 if (strEQ(d,"do")) return KEY_do;
4334 if (strEQ(d,"die")) return -KEY_die;
4337 if (strEQ(d,"dump")) return -KEY_dump;
4340 if (strEQ(d,"delete")) return KEY_delete;
4343 if (strEQ(d,"defined")) return KEY_defined;
4344 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4347 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4352 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4353 if (strEQ(d,"END")) return KEY_END;
4358 if (strEQ(d,"eq")) return -KEY_eq;
4361 if (strEQ(d,"eof")) return -KEY_eof;
4362 if (strEQ(d,"exp")) return -KEY_exp;
4365 if (strEQ(d,"else")) return KEY_else;
4366 if (strEQ(d,"exit")) return -KEY_exit;
4367 if (strEQ(d,"eval")) return KEY_eval;
4368 if (strEQ(d,"exec")) return -KEY_exec;
4369 if (strEQ(d,"each")) return KEY_each;
4372 if (strEQ(d,"elsif")) return KEY_elsif;
4375 if (strEQ(d,"exists")) return KEY_exists;
4376 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4379 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4380 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4383 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4386 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4387 if (strEQ(d,"endservent")) return -KEY_endservent;
4390 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4397 if (strEQ(d,"for")) return KEY_for;
4400 if (strEQ(d,"fork")) return -KEY_fork;
4403 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4404 if (strEQ(d,"flock")) return -KEY_flock;
4407 if (strEQ(d,"format")) return KEY_format;
4408 if (strEQ(d,"fileno")) return -KEY_fileno;
4411 if (strEQ(d,"foreach")) return KEY_foreach;
4414 if (strEQ(d,"formline")) return -KEY_formline;
4420 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4421 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4425 if (strnEQ(d,"get",3)) {
4430 if (strEQ(d,"ppid")) return -KEY_getppid;
4431 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4434 if (strEQ(d,"pwent")) return -KEY_getpwent;
4435 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4436 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4439 if (strEQ(d,"peername")) return -KEY_getpeername;
4440 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4441 if (strEQ(d,"priority")) return -KEY_getpriority;
4444 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4447 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4451 else if (*d == 'h') {
4452 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4453 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4454 if (strEQ(d,"hostent")) return -KEY_gethostent;
4456 else if (*d == 'n') {
4457 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4458 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4459 if (strEQ(d,"netent")) return -KEY_getnetent;
4461 else if (*d == 's') {
4462 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4463 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4464 if (strEQ(d,"servent")) return -KEY_getservent;
4465 if (strEQ(d,"sockname")) return -KEY_getsockname;
4466 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4468 else if (*d == 'g') {
4469 if (strEQ(d,"grent")) return -KEY_getgrent;
4470 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4471 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4473 else if (*d == 'l') {
4474 if (strEQ(d,"login")) return -KEY_getlogin;
4476 else if (strEQ(d,"c")) return -KEY_getc;
4481 if (strEQ(d,"gt")) return -KEY_gt;
4482 if (strEQ(d,"ge")) return -KEY_ge;
4485 if (strEQ(d,"grep")) return KEY_grep;
4486 if (strEQ(d,"goto")) return KEY_goto;
4487 if (strEQ(d,"glob")) return KEY_glob;
4490 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4495 if (strEQ(d,"hex")) return -KEY_hex;
4498 if (strEQ(d,"INIT")) return KEY_INIT;
4503 if (strEQ(d,"if")) return KEY_if;
4506 if (strEQ(d,"int")) return -KEY_int;
4509 if (strEQ(d,"index")) return -KEY_index;
4510 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4515 if (strEQ(d,"join")) return -KEY_join;
4519 if (strEQ(d,"keys")) return KEY_keys;
4520 if (strEQ(d,"kill")) return -KEY_kill;
4525 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4526 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4532 if (strEQ(d,"lt")) return -KEY_lt;
4533 if (strEQ(d,"le")) return -KEY_le;
4534 if (strEQ(d,"lc")) return -KEY_lc;
4537 if (strEQ(d,"log")) return -KEY_log;
4540 if (strEQ(d,"last")) return KEY_last;
4541 if (strEQ(d,"link")) return -KEY_link;
4542 if (strEQ(d,"lock")) return -KEY_lock;
4545 if (strEQ(d,"local")) return KEY_local;
4546 if (strEQ(d,"lstat")) return -KEY_lstat;
4549 if (strEQ(d,"length")) return -KEY_length;
4550 if (strEQ(d,"listen")) return -KEY_listen;
4553 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4556 if (strEQ(d,"localtime")) return -KEY_localtime;
4562 case 1: return KEY_m;
4564 if (strEQ(d,"my")) return KEY_my;
4567 if (strEQ(d,"map")) return KEY_map;
4570 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4573 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4574 if (strEQ(d,"msgget")) return -KEY_msgget;
4575 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4576 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4581 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4584 if (strEQ(d,"next")) return KEY_next;
4585 if (strEQ(d,"ne")) return -KEY_ne;
4586 if (strEQ(d,"not")) return -KEY_not;
4587 if (strEQ(d,"no")) return KEY_no;
4592 if (strEQ(d,"or")) return -KEY_or;
4595 if (strEQ(d,"ord")) return -KEY_ord;
4596 if (strEQ(d,"oct")) return -KEY_oct;
4597 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4601 if (strEQ(d,"open")) return -KEY_open;
4604 if (strEQ(d,"opendir")) return -KEY_opendir;
4611 if (strEQ(d,"pop")) return KEY_pop;
4612 if (strEQ(d,"pos")) return KEY_pos;
4615 if (strEQ(d,"push")) return KEY_push;
4616 if (strEQ(d,"pack")) return -KEY_pack;
4617 if (strEQ(d,"pipe")) return -KEY_pipe;
4620 if (strEQ(d,"print")) return KEY_print;
4623 if (strEQ(d,"printf")) return KEY_printf;
4626 if (strEQ(d,"package")) return KEY_package;
4629 if (strEQ(d,"prototype")) return KEY_prototype;
4634 if (strEQ(d,"q")) return KEY_q;
4635 if (strEQ(d,"qr")) return KEY_qr;
4636 if (strEQ(d,"qq")) return KEY_qq;
4637 if (strEQ(d,"qw")) return KEY_qw;
4638 if (strEQ(d,"qx")) return KEY_qx;
4640 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4645 if (strEQ(d,"ref")) return -KEY_ref;
4648 if (strEQ(d,"read")) return -KEY_read;
4649 if (strEQ(d,"rand")) return -KEY_rand;
4650 if (strEQ(d,"recv")) return -KEY_recv;
4651 if (strEQ(d,"redo")) return KEY_redo;
4654 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4655 if (strEQ(d,"reset")) return -KEY_reset;
4658 if (strEQ(d,"return")) return KEY_return;
4659 if (strEQ(d,"rename")) return -KEY_rename;
4660 if (strEQ(d,"rindex")) return -KEY_rindex;
4663 if (strEQ(d,"require")) return -KEY_require;
4664 if (strEQ(d,"reverse")) return -KEY_reverse;
4665 if (strEQ(d,"readdir")) return -KEY_readdir;
4668 if (strEQ(d,"readlink")) return -KEY_readlink;
4669 if (strEQ(d,"readline")) return -KEY_readline;
4670 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4673 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4679 case 0: return KEY_s;
4681 if (strEQ(d,"scalar")) return KEY_scalar;
4686 if (strEQ(d,"seek")) return -KEY_seek;
4687 if (strEQ(d,"send")) return -KEY_send;
4690 if (strEQ(d,"semop")) return -KEY_semop;
4693 if (strEQ(d,"select")) return -KEY_select;
4694 if (strEQ(d,"semctl")) return -KEY_semctl;
4695 if (strEQ(d,"semget")) return -KEY_semget;
4698 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4699 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4702 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4703 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4706 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4709 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4710 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4711 if (strEQ(d,"setservent")) return -KEY_setservent;
4714 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4715 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4722 if (strEQ(d,"shift")) return KEY_shift;
4725 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4726 if (strEQ(d,"shmget")) return -KEY_shmget;
4729 if (strEQ(d,"shmread")) return -KEY_shmread;
4732 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4733 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4738 if (strEQ(d,"sin")) return -KEY_sin;
4741 if (strEQ(d,"sleep")) return -KEY_sleep;
4744 if (strEQ(d,"sort")) return KEY_sort;
4745 if (strEQ(d,"socket")) return -KEY_socket;
4746 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4749 if (strEQ(d,"split")) return KEY_split;
4750 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4751 if (strEQ(d,"splice")) return KEY_splice;
4754 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4757 if (strEQ(d,"srand")) return -KEY_srand;
4760 if (strEQ(d,"stat")) return -KEY_stat;
4761 if (strEQ(d,"study")) return KEY_study;
4764 if (strEQ(d,"substr")) return -KEY_substr;
4765 if (strEQ(d,"sub")) return KEY_sub;
4770 if (strEQ(d,"system")) return -KEY_system;
4773 if (strEQ(d,"symlink")) return -KEY_symlink;
4774 if (strEQ(d,"syscall")) return -KEY_syscall;
4775 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4776 if (strEQ(d,"sysread")) return -KEY_sysread;
4777 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4780 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4789 if (strEQ(d,"tr")) return KEY_tr;
4792 if (strEQ(d,"tie")) return KEY_tie;
4795 if (strEQ(d,"tell")) return -KEY_tell;
4796 if (strEQ(d,"tied")) return KEY_tied;
4797 if (strEQ(d,"time")) return -KEY_time;
4800 if (strEQ(d,"times")) return -KEY_times;
4803 if (strEQ(d,"telldir")) return -KEY_telldir;
4806 if (strEQ(d,"truncate")) return -KEY_truncate;
4813 if (strEQ(d,"uc")) return -KEY_uc;
4816 if (strEQ(d,"use")) return KEY_use;
4819 if (strEQ(d,"undef")) return KEY_undef;
4820 if (strEQ(d,"until")) return KEY_until;
4821 if (strEQ(d,"untie")) return KEY_untie;
4822 if (strEQ(d,"utime")) return -KEY_utime;
4823 if (strEQ(d,"umask")) return -KEY_umask;
4826 if (strEQ(d,"unless")) return KEY_unless;
4827 if (strEQ(d,"unpack")) return -KEY_unpack;
4828 if (strEQ(d,"unlink")) return -KEY_unlink;
4831 if (strEQ(d,"unshift")) return KEY_unshift;
4832 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4837 if (strEQ(d,"values")) return -KEY_values;
4838 if (strEQ(d,"vec")) return -KEY_vec;
4843 if (strEQ(d,"warn")) return -KEY_warn;
4844 if (strEQ(d,"wait")) return -KEY_wait;
4847 if (strEQ(d,"while")) return KEY_while;
4848 if (strEQ(d,"write")) return -KEY_write;
4851 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4854 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4859 if (len == 1) return -KEY_x;
4860 if (strEQ(d,"xor")) return -KEY_xor;
4863 if (len == 1) return KEY_y;
4872 checkcomma(register char *s, char *name, char *what)
4876 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4877 dTHR; /* only for ckWARN */
4878 if (ckWARN(WARN_SYNTAX)) {
4880 for (w = s+2; *w && level; w++) {
4887 for (; *w && isSPACE(*w); w++) ;
4888 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4889 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4892 while (s < PL_bufend && isSPACE(*s))
4896 while (s < PL_bufend && isSPACE(*s))
4898 if (isIDFIRST(*s)) {
4902 while (s < PL_bufend && isSPACE(*s))
4907 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4911 croak("No comma allowed after %s", what);
4917 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4920 HV *table = GvHV(PL_hintgv); /* ^H */
4923 bool oldcatch = CATCH_GET;
4929 yyerror("%^H is not defined");
4932 cvp = hv_fetch(table, key, strlen(key), FALSE);
4933 if (!cvp || !SvOK(*cvp)) {
4934 sprintf(buf,"$^H{%s} is not defined", key);
4938 sv_2mortal(sv); /* Parent created it permanently */
4941 pv = sv_2mortal(newSVpv(s, len));
4943 typesv = sv_2mortal(newSVpv(type, 0));
4945 typesv = &PL_sv_undef;
4947 Zero(&myop, 1, BINOP);
4948 myop.op_last = (OP *) &myop;
4949 myop.op_next = Nullop;
4950 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4952 PUSHSTACKi(PERLSI_OVERLOAD);
4955 PL_op = (OP *) &myop;
4956 if (PERLDB_SUB && PL_curstash != PL_debstash)
4957 PL_op->op_private |= OPpENTERSUB_DB;
4968 if (PL_op = pp_entersub(ARGS))
4975 CATCH_SET(oldcatch);
4979 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4982 return SvREFCNT_inc(res);
4986 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4988 register char *d = dest;
4989 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4992 croak(ident_too_long);
4995 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
5000 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5004 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
5005 char *t = s + UTF8SKIP(s);
5006 while (*t & 0x80 && is_utf8_mark((U8*)t))
5008 if (d + (t - s) > e)
5009 croak(ident_too_long);
5010 Copy(s, d, t - s, char);
5023 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5030 if (PL_lex_brackets == 0)
5031 PL_lex_fakebrack = 0;
5035 e = d + destlen - 3; /* two-character token, ending NUL */
5037 while (isDIGIT(*s)) {
5039 croak(ident_too_long);
5046 croak(ident_too_long);
5049 else if (*s == '\'' && isIDFIRST(s[1])) {
5054 else if (*s == ':' && s[1] == ':') {
5058 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
5059 char *t = s + UTF8SKIP(s);
5060 while (*t & 0x80 && is_utf8_mark((U8*)t))
5062 if (d + (t - s) > e)
5063 croak(ident_too_long);
5064 Copy(s, d, t - s, char);
5075 if (PL_lex_state != LEX_NORMAL)
5076 PL_lex_state = LEX_INTERPENDMAYBE;
5079 if (*s == '$' && s[1] &&
5080 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5093 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5098 if (isSPACE(s[-1])) {
5101 if (ch != ' ' && ch != '\t') {
5107 if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8((U8*)d))) {
5111 while (e < send && (isALNUM(*e) || ((*e & 0xc0) == 0x80 && isALNUM_utf8((U8*)e)) || *e == ':')) {
5113 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5116 Copy(s, d, e - s, char);
5121 while (isALNUM(*s) || *s == ':')
5125 while (s < send && (*s == ' ' || *s == '\t')) s++;
5126 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5127 dTHR; /* only for ckWARN */
5128 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5129 char *brack = *s == '[' ? "[...]" : "{...}";
5130 warner(WARN_AMBIGUOUS,
5131 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5132 funny, dest, brack, funny, dest, brack);
5134 PL_lex_fakebrack = PL_lex_brackets+1;
5136 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5142 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5143 PL_lex_state = LEX_INTERPEND;
5146 if (PL_lex_state == LEX_NORMAL) {
5147 dTHR; /* only for ckWARN */
5148 if (ckWARN(WARN_AMBIGUOUS) &&
5149 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5151 warner(WARN_AMBIGUOUS,
5152 "Ambiguous use of %c{%s} resolved to %c%s",
5153 funny, dest, funny, dest);
5158 s = bracket; /* let the parser handle it */
5162 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5163 PL_lex_state = LEX_INTERPEND;
5167 void pmflag(U16 *pmfl, int ch)
5172 *pmfl |= PMf_GLOBAL;
5174 *pmfl |= PMf_CONTINUE;
5178 *pmfl |= PMf_MULTILINE;
5180 *pmfl |= PMf_SINGLELINE;
5182 *pmfl |= PMf_EXTENDED;
5186 scan_pat(char *start, I32 type)
5191 s = scan_str(start);
5194 SvREFCNT_dec(PL_lex_stuff);
5195 PL_lex_stuff = Nullsv;
5196 croak("Search pattern not terminated");
5199 pm = (PMOP*)newPMOP(type, 0);
5200 if (PL_multi_open == '?')
5201 pm->op_pmflags |= PMf_ONCE;
5203 while (*s && strchr("iomsx", *s))
5204 pmflag(&pm->op_pmflags,*s++);
5207 while (*s && strchr("iogcmsx", *s))
5208 pmflag(&pm->op_pmflags,*s++);
5210 pm->op_pmpermflags = pm->op_pmflags;
5212 PL_lex_op = (OP*)pm;
5213 yylval.ival = OP_MATCH;
5218 scan_subst(char *start)
5225 yylval.ival = OP_NULL;
5227 s = scan_str(start);
5231 SvREFCNT_dec(PL_lex_stuff);
5232 PL_lex_stuff = Nullsv;
5233 croak("Substitution pattern not terminated");
5236 if (s[-1] == PL_multi_open)
5239 first_start = PL_multi_start;
5243 SvREFCNT_dec(PL_lex_stuff);
5244 PL_lex_stuff = Nullsv;
5246 SvREFCNT_dec(PL_lex_repl);
5247 PL_lex_repl = Nullsv;
5248 croak("Substitution replacement not terminated");
5250 PL_multi_start = first_start; /* so whole substitution is taken together */
5252 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5258 else if (strchr("iogcmsx", *s))
5259 pmflag(&pm->op_pmflags,*s++);
5266 pm->op_pmflags |= PMf_EVAL;
5267 repl = newSVpv("",0);
5269 sv_catpv(repl, es ? "eval " : "do ");
5270 sv_catpvn(repl, "{ ", 2);
5271 sv_catsv(repl, PL_lex_repl);
5272 sv_catpvn(repl, " };", 2);
5273 SvCOMPILED_on(repl);
5274 SvREFCNT_dec(PL_lex_repl);
5278 pm->op_pmpermflags = pm->op_pmflags;
5279 PL_lex_op = (OP*)pm;
5280 yylval.ival = OP_SUBST;
5285 scan_trans(char *start)
5296 yylval.ival = OP_NULL;
5298 s = scan_str(start);
5301 SvREFCNT_dec(PL_lex_stuff);
5302 PL_lex_stuff = Nullsv;
5303 croak("Transliteration pattern not terminated");
5305 if (s[-1] == PL_multi_open)
5311 SvREFCNT_dec(PL_lex_stuff);
5312 PL_lex_stuff = Nullsv;
5314 SvREFCNT_dec(PL_lex_repl);
5315 PL_lex_repl = Nullsv;
5316 croak("Transliteration replacement not terminated");
5320 o = newSVOP(OP_TRANS, 0, 0);
5321 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5324 New(803,tbl,256,short);
5325 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5329 complement = del = squash = 0;
5330 while (strchr("cdsCU", *s)) {
5332 complement = OPpTRANS_COMPLEMENT;
5334 del = OPpTRANS_DELETE;
5336 squash = OPpTRANS_SQUASH;
5341 utf8 &= ~OPpTRANS_FROM_UTF;
5343 utf8 |= OPpTRANS_FROM_UTF;
5347 utf8 &= ~OPpTRANS_TO_UTF;
5349 utf8 |= OPpTRANS_TO_UTF;
5352 croak("Too many /C and /U options");
5357 o->op_private = del|squash|complement|utf8;
5360 yylval.ival = OP_TRANS;
5365 scan_heredoc(register char *s)
5369 I32 op_type = OP_SCALAR;
5376 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5380 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5383 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5384 if (*peek && strchr("`'\"",*peek)) {
5387 s = delimcpy(d, e, s, PL_bufend, term, &len);
5398 deprecate("bare << to mean <<\"\"");
5399 for (; isALNUM(*s); s++) {
5404 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5405 croak("Delimiter for here document is too long");
5408 len = d - PL_tokenbuf;
5409 #ifndef PERL_STRICT_CR
5410 d = strchr(s, '\r');
5414 while (s < PL_bufend) {
5420 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5429 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5434 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5435 herewas = newSVpv(s,PL_bufend-s);
5437 s--, herewas = newSVpv(s,d-s);
5438 s += SvCUR(herewas);
5440 tmpstr = NEWSV(87,79);
5441 sv_upgrade(tmpstr, SVt_PVIV);
5446 else if (term == '`') {
5447 op_type = OP_BACKTICK;
5448 SvIVX(tmpstr) = '\\';
5452 PL_multi_start = PL_curcop->cop_line;
5453 PL_multi_open = PL_multi_close = '<';
5454 term = *PL_tokenbuf;
5457 while (s < PL_bufend &&
5458 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5460 PL_curcop->cop_line++;
5462 if (s >= PL_bufend) {
5463 PL_curcop->cop_line = PL_multi_start;
5464 missingterm(PL_tokenbuf);
5466 sv_setpvn(tmpstr,d+1,s-d);
5468 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5470 sv_catpvn(herewas,s,PL_bufend-s);
5471 sv_setsv(PL_linestr,herewas);
5472 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5473 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5476 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5477 while (s >= PL_bufend) { /* multiple line string? */
5479 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5480 PL_curcop->cop_line = PL_multi_start;
5481 missingterm(PL_tokenbuf);
5483 PL_curcop->cop_line++;
5484 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5485 #ifndef PERL_STRICT_CR
5486 if (PL_bufend - PL_linestart >= 2) {
5487 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5488 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5490 PL_bufend[-2] = '\n';
5492 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5494 else if (PL_bufend[-1] == '\r')
5495 PL_bufend[-1] = '\n';
5497 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5498 PL_bufend[-1] = '\n';
5500 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5501 SV *sv = NEWSV(88,0);
5503 sv_upgrade(sv, SVt_PVMG);
5504 sv_setsv(sv,PL_linestr);
5505 av_store(GvAV(PL_curcop->cop_filegv),
5506 (I32)PL_curcop->cop_line,sv);
5508 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5511 sv_catsv(PL_linestr,herewas);
5512 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5516 sv_catsv(tmpstr,PL_linestr);
5519 PL_multi_end = PL_curcop->cop_line;
5521 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5522 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5523 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5525 SvREFCNT_dec(herewas);
5526 PL_lex_stuff = tmpstr;
5527 yylval.ival = op_type;
5532 takes: current position in input buffer
5533 returns: new position in input buffer
5534 side-effects: yylval and lex_op are set.
5539 <FH> read from filehandle
5540 <pkg::FH> read from package qualified filehandle
5541 <pkg'FH> read from package qualified filehandle
5542 <$fh> read from filehandle in $fh
5548 scan_inputsymbol(char *start)
5550 register char *s = start; /* current position in buffer */
5555 d = PL_tokenbuf; /* start of temp holding space */
5556 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5557 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5559 /* die if we didn't have space for the contents of the <>,
5563 if (len >= sizeof PL_tokenbuf)
5564 croak("Excessively long <> operator");
5566 croak("Unterminated <> operator");
5571 Remember, only scalar variables are interpreted as filehandles by
5572 this code. Anything more complex (e.g., <$fh{$num}>) will be
5573 treated as a glob() call.
5574 This code makes use of the fact that except for the $ at the front,
5575 a scalar variable and a filehandle look the same.
5577 if (*d == '$' && d[1]) d++;
5579 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5580 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5583 /* If we've tried to read what we allow filehandles to look like, and
5584 there's still text left, then it must be a glob() and not a getline.
5585 Use scan_str to pull out the stuff between the <> and treat it
5586 as nothing more than a string.
5589 if (d - PL_tokenbuf != len) {
5590 yylval.ival = OP_GLOB;
5592 s = scan_str(start);
5594 croak("Glob not terminated");
5598 /* we're in a filehandle read situation */
5601 /* turn <> into <ARGV> */
5603 (void)strcpy(d,"ARGV");
5605 /* if <$fh>, create the ops to turn the variable into a
5611 /* try to find it in the pad for this block, otherwise find
5612 add symbol table ops
5614 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5615 OP *o = newOP(OP_PADSV, 0);
5617 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5620 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5621 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5622 newUNOP(OP_RV2GV, 0,
5623 newUNOP(OP_RV2SV, 0,
5624 newGVOP(OP_GV, 0, gv))));
5626 /* we created the ops in lex_op, so make yylval.ival a null op */
5627 yylval.ival = OP_NULL;
5630 /* If it's none of the above, it must be a literal filehandle
5631 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5633 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5634 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5635 yylval.ival = OP_NULL;
5644 takes: start position in buffer
5645 returns: position to continue reading from buffer
5646 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5647 updates the read buffer.
5649 This subroutine pulls a string out of the input. It is called for:
5650 q single quotes q(literal text)
5651 ' single quotes 'literal text'
5652 qq double quotes qq(interpolate $here please)
5653 " double quotes "interpolate $here please"
5654 qx backticks qx(/bin/ls -l)
5655 ` backticks `/bin/ls -l`
5656 qw quote words @EXPORT_OK = qw( func() $spam )
5657 m// regexp match m/this/
5658 s/// regexp substitute s/this/that/
5659 tr/// string transliterate tr/this/that/
5660 y/// string transliterate y/this/that/
5661 ($*@) sub prototypes sub foo ($)
5662 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5664 In most of these cases (all but <>, patterns and transliterate)
5665 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5666 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5667 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5670 It skips whitespace before the string starts, and treats the first
5671 character as the delimiter. If the delimiter is one of ([{< then
5672 the corresponding "close" character )]}> is used as the closing
5673 delimiter. It allows quoting of delimiters, and if the string has
5674 balanced delimiters ([{<>}]) it allows nesting.
5676 The lexer always reads these strings into lex_stuff, except in the
5677 case of the operators which take *two* arguments (s/// and tr///)
5678 when it checks to see if lex_stuff is full (presumably with the 1st
5679 arg to s or tr) and if so puts the string into lex_repl.
5684 scan_str(char *start)
5687 SV *sv; /* scalar value: string */
5688 char *tmps; /* temp string, used for delimiter matching */
5689 register char *s = start; /* current position in the buffer */
5690 register char term; /* terminating character */
5691 register char *to; /* current position in the sv's data */
5692 I32 brackets = 1; /* bracket nesting level */
5694 /* skip space before the delimiter */
5698 /* mark where we are, in case we need to report errors */
5701 /* after skipping whitespace, the next character is the terminator */
5703 /* mark where we are */
5704 PL_multi_start = PL_curcop->cop_line;
5705 PL_multi_open = term;
5707 /* find corresponding closing delimiter */
5708 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5710 PL_multi_close = term;
5712 /* create a new SV to hold the contents. 87 is leak category, I'm
5713 assuming. 79 is the SV's initial length. What a random number. */
5715 sv_upgrade(sv, SVt_PVIV);
5717 (void)SvPOK_only(sv); /* validate pointer */
5719 /* move past delimiter and try to read a complete string */
5722 /* extend sv if need be */
5723 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5724 /* set 'to' to the next character in the sv's string */
5725 to = SvPVX(sv)+SvCUR(sv);
5727 /* if open delimiter is the close delimiter read unbridle */
5728 if (PL_multi_open == PL_multi_close) {
5729 for (; s < PL_bufend; s++,to++) {
5730 /* embedded newlines increment the current line number */
5731 if (*s == '\n' && !PL_rsfp)
5732 PL_curcop->cop_line++;
5733 /* handle quoted delimiters */
5734 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5737 /* any other quotes are simply copied straight through */
5741 /* terminate when run out of buffer (the for() condition), or
5742 have found the terminator */
5743 else if (*s == term)
5749 /* if the terminator isn't the same as the start character (e.g.,
5750 matched brackets), we have to allow more in the quoting, and
5751 be prepared for nested brackets.
5754 /* read until we run out of string, or we find the terminator */
5755 for (; s < PL_bufend; s++,to++) {
5756 /* embedded newlines increment the line count */
5757 if (*s == '\n' && !PL_rsfp)
5758 PL_curcop->cop_line++;
5759 /* backslashes can escape the open or closing characters */
5760 if (*s == '\\' && s+1 < PL_bufend) {
5761 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5766 /* allow nested opens and closes */
5767 else if (*s == PL_multi_close && --brackets <= 0)
5769 else if (*s == PL_multi_open)
5774 /* terminate the copied string and update the sv's end-of-string */
5776 SvCUR_set(sv, to - SvPVX(sv));
5779 * this next chunk reads more into the buffer if we're not done yet
5782 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5784 #ifndef PERL_STRICT_CR
5785 if (to - SvPVX(sv) >= 2) {
5786 if ((to[-2] == '\r' && to[-1] == '\n') ||
5787 (to[-2] == '\n' && to[-1] == '\r'))
5791 SvCUR_set(sv, to - SvPVX(sv));
5793 else if (to[-1] == '\r')
5796 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5800 /* if we're out of file, or a read fails, bail and reset the current
5801 line marker so we can report where the unterminated string began
5804 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5806 PL_curcop->cop_line = PL_multi_start;
5809 /* we read a line, so increment our line counter */
5810 PL_curcop->cop_line++;
5812 /* update debugger info */
5813 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5814 SV *sv = NEWSV(88,0);
5816 sv_upgrade(sv, SVt_PVMG);
5817 sv_setsv(sv,PL_linestr);
5818 av_store(GvAV(PL_curcop->cop_filegv),
5819 (I32)PL_curcop->cop_line, sv);
5822 /* having changed the buffer, we must update PL_bufend */
5823 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5826 /* at this point, we have successfully read the delimited string */
5828 PL_multi_end = PL_curcop->cop_line;
5831 /* if we allocated too much space, give some back */
5832 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5833 SvLEN_set(sv, SvCUR(sv) + 1);
5834 Renew(SvPVX(sv), SvLEN(sv), char);
5837 /* decide whether this is the first or second quoted string we've read
5850 takes: pointer to position in buffer
5851 returns: pointer to new position in buffer
5852 side-effects: builds ops for the constant in yylval.op
5854 Read a number in any of the formats that Perl accepts:
5856 0(x[0-7A-F]+)|([0-7]+)
5857 [\d_]+(\.[\d_]*)?[Ee](\d+)
5859 Underbars (_) are allowed in decimal numbers. If -w is on,
5860 underbars before a decimal point must be at three digit intervals.
5862 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5865 If it reads a number without a decimal point or an exponent, it will
5866 try converting the number to an integer and see if it can do so
5867 without loss of precision.
5871 scan_num(char *start)
5873 register char *s = start; /* current position in buffer */
5874 register char *d; /* destination in temp buffer */
5875 register char *e; /* end of temp buffer */
5876 I32 tryiv; /* used to see if it can be an int */
5877 double value; /* number read, as a double */
5878 SV *sv; /* place to put the converted number */
5879 I32 floatit; /* boolean: int or float? */
5880 char *lastub = 0; /* position of last underbar */
5881 static char number_too_long[] = "Number too long";
5883 /* We use the first character to decide what type of number this is */
5887 croak("panic: scan_num");
5889 /* if it starts with a 0, it could be an octal number, a decimal in
5890 0.13 disguise, or a hexadecimal number.
5895 u holds the "number so far"
5896 shift the power of 2 of the base (hex == 4, octal == 3)
5897 overflowed was the number more than we can hold?
5899 Shift is used when we add a digit. It also serves as an "are
5900 we in octal or hex?" indicator to disallow hex characters when
5905 bool overflowed = FALSE;
5912 /* check for a decimal in disguise */
5913 else if (s[1] == '.')
5915 /* so it must be octal */
5920 /* read the rest of the octal number */
5922 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5926 /* if we don't mention it, we're done */
5935 /* 8 and 9 are not octal */
5938 yyerror("Illegal octal digit");
5942 case '0': case '1': case '2': case '3': case '4':
5943 case '5': case '6': case '7':
5944 b = *s++ & 15; /* ASCII digit -> value of digit */
5948 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5949 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5950 /* make sure they said 0x */
5955 /* Prepare to put the digit we have onto the end
5956 of the number so far. We check for overflows.
5960 n = u << shift; /* make room for the digit */
5961 if (!overflowed && (n >> shift) != u
5962 && !(PL_hints & HINT_NEW_BINARY)) {
5963 warn("Integer overflow in %s number",
5964 (shift == 4) ? "hex" : "octal");
5967 u = n | b; /* add the digit to the end */
5972 /* if we get here, we had success: make a scalar value from
5978 if ( PL_hints & HINT_NEW_BINARY)
5979 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5984 handle decimal numbers.
5985 we're also sent here when we read a 0 as the first digit
5987 case '1': case '2': case '3': case '4': case '5':
5988 case '6': case '7': case '8': case '9': case '.':
5991 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5994 /* read next group of digits and _ and copy into d */
5995 while (isDIGIT(*s) || *s == '_') {
5996 /* skip underscores, checking for misplaced ones
6000 dTHR; /* only for ckWARN */
6001 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6002 warner(WARN_SYNTAX, "Misplaced _ in number");
6006 /* check for end of fixed-length buffer */
6008 croak(number_too_long);
6009 /* if we're ok, copy the character */
6014 /* final misplaced underbar check */
6015 if (lastub && s - lastub != 3) {
6017 if (ckWARN(WARN_SYNTAX))
6018 warner(WARN_SYNTAX, "Misplaced _ in number");
6021 /* read a decimal portion if there is one. avoid
6022 3..5 being interpreted as the number 3. followed
6025 if (*s == '.' && s[1] != '.') {
6029 /* copy, ignoring underbars, until we run out of
6030 digits. Note: no misplaced underbar checks!
6032 for (; isDIGIT(*s) || *s == '_'; s++) {
6033 /* fixed length buffer check */
6035 croak(number_too_long);
6041 /* read exponent part, if present */
6042 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6046 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6047 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6049 /* allow positive or negative exponent */
6050 if (*s == '+' || *s == '-')
6053 /* read digits of exponent (no underbars :-) */
6054 while (isDIGIT(*s)) {
6056 croak(number_too_long);
6061 /* terminate the string */
6064 /* make an sv from the string */
6066 /* reset numeric locale in case we were earlier left in Swaziland */
6067 SET_NUMERIC_STANDARD();
6068 value = atof(PL_tokenbuf);
6071 See if we can make do with an integer value without loss of
6072 precision. We use I_V to cast to an int, because some
6073 compilers have issues. Then we try casting it back and see
6074 if it was the same. We only do this if we know we
6075 specifically read an integer.
6077 Note: if floatit is true, then we don't need to do the
6081 if (!floatit && (double)tryiv == value)
6082 sv_setiv(sv, tryiv);
6084 sv_setnv(sv, value);
6085 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6086 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6087 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6091 /* make the op for the constant and return */
6093 yylval.opval = newSVOP(OP_CONST, 0, sv);
6099 scan_formline(register char *s)
6104 SV *stuff = newSVpv("",0);
6105 bool needargs = FALSE;
6108 if (*s == '.' || *s == '}') {
6110 #ifdef PERL_STRICT_CR
6111 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6113 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6118 if (PL_in_eval && !PL_rsfp) {
6119 eol = strchr(s,'\n');
6124 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6126 for (t = s; t < eol; t++) {
6127 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6129 goto enough; /* ~~ must be first line in formline */
6131 if (*t == '@' || *t == '^')
6134 sv_catpvn(stuff, s, eol-s);
6138 s = filter_gets(PL_linestr, PL_rsfp, 0);
6139 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6140 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6143 yyerror("Format not terminated");
6153 PL_lex_state = LEX_NORMAL;
6154 PL_nextval[PL_nexttoke].ival = 0;
6158 PL_lex_state = LEX_FORMLINE;
6159 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6161 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6165 SvREFCNT_dec(stuff);
6166 PL_lex_formbrack = 0;
6177 PL_cshlen = strlen(PL_cshname);
6182 start_subparse(I32 is_format, U32 flags)
6185 I32 oldsavestack_ix = PL_savestack_ix;
6186 CV* outsidecv = PL_compcv;
6190 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6192 save_I32(&PL_subline);
6193 save_item(PL_subname);
6195 SAVESPTR(PL_curpad);
6196 SAVESPTR(PL_comppad);
6197 SAVESPTR(PL_comppad_name);
6198 SAVESPTR(PL_compcv);
6199 SAVEI32(PL_comppad_name_fill);
6200 SAVEI32(PL_min_intro_pending);
6201 SAVEI32(PL_max_intro_pending);
6202 SAVEI32(PL_pad_reset_pending);
6204 PL_compcv = (CV*)NEWSV(1104,0);
6205 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6206 CvFLAGS(PL_compcv) |= flags;
6208 PL_comppad = newAV();
6209 av_push(PL_comppad, Nullsv);
6210 PL_curpad = AvARRAY(PL_comppad);
6211 PL_comppad_name = newAV();
6212 PL_comppad_name_fill = 0;
6213 PL_min_intro_pending = 0;
6215 PL_subline = PL_curcop->cop_line;
6217 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6218 PL_curpad[0] = (SV*)newAV();
6219 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6220 #endif /* USE_THREADS */
6222 comppadlist = newAV();
6223 AvREAL_off(comppadlist);
6224 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6225 av_store(comppadlist, 1, (SV*)PL_comppad);
6227 CvPADLIST(PL_compcv) = comppadlist;
6228 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6230 CvOWNER(PL_compcv) = 0;
6231 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6232 MUTEX_INIT(CvMUTEXP(PL_compcv));
6233 #endif /* USE_THREADS */
6235 return oldsavestack_ix;
6254 char *context = NULL;
6258 if (!yychar || (yychar == ';' && !PL_rsfp))
6260 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6261 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6262 while (isSPACE(*PL_oldoldbufptr))
6264 context = PL_oldoldbufptr;
6265 contlen = PL_bufptr - PL_oldoldbufptr;
6267 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6268 PL_oldbufptr != PL_bufptr) {
6269 while (isSPACE(*PL_oldbufptr))
6271 context = PL_oldbufptr;
6272 contlen = PL_bufptr - PL_oldbufptr;
6274 else if (yychar > 255)
6275 where = "next token ???";
6276 else if ((yychar & 127) == 127) {
6277 if (PL_lex_state == LEX_NORMAL ||
6278 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6279 where = "at end of line";
6280 else if (PL_lex_inpat)
6281 where = "within pattern";
6283 where = "within string";
6286 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6288 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6289 else if (isPRINT_LC(yychar))
6290 sv_catpvf(where_sv, "%c", yychar);
6292 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6293 where = SvPVX(where_sv);
6295 msg = sv_2mortal(newSVpv(s, 0));
6296 sv_catpvf(msg, " at %_ line %ld, ",
6297 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6299 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6301 sv_catpvf(msg, "%s\n", where);
6302 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6304 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6305 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6310 else if (PL_in_eval)
6311 sv_catsv(ERRSV, msg);
6313 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6314 if (++PL_error_count >= 10)
6315 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6317 PL_in_my_stash = Nullhv;