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
18 static void check_uni _((void));
19 static void force_next _((I32 type));
20 static char *force_version _((char *start));
21 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
22 static SV *tokeq _((SV *sv));
23 static char *scan_const _((char *start));
24 static char *scan_formline _((char *s));
25 static char *scan_heredoc _((char *s));
26 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
28 static char *scan_inputsymbol _((char *start));
29 static char *scan_pat _((char *start, I32 type));
30 static char *scan_str _((char *start));
31 static char *scan_subst _((char *start));
32 static char *scan_trans _((char *start));
33 static char *scan_word _((char *s, char *dest, STRLEN destlen,
34 int allow_package, STRLEN *slp));
35 static char *skipspace _((char *s));
36 static void checkcomma _((char *s, char *name, char *what));
37 static void force_ident _((char *s, int kind));
38 static void incline _((char *s));
39 static int intuit_method _((char *s, GV *gv));
40 static int intuit_more _((char *s));
41 static I32 lop _((I32 f, expectation x, char *s));
42 static void missingterm _((char *s));
43 static void no_op _((char *what, char *s));
44 static void set_csh _((void));
45 static I32 sublex_done _((void));
46 static I32 sublex_push _((void));
47 static I32 sublex_start _((void));
49 static int uni _((I32 f, char *s));
51 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
52 static void restore_rsfp _((void *f));
53 static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
54 static void restore_expect _((void *e));
55 static void restore_lex_expect _((void *e));
56 #endif /* PERL_OBJECT */
58 static char ident_too_long[] = "Identifier too long";
60 #define UTF (PL_hints & HINT_UTF8)
62 /* The following are arranged oddly so that the guard on the switch statement
63 * can get by with a single comparison (if the compiler is smart enough).
66 /* #define LEX_NOTPARSING 11 is done in perl.h. */
69 #define LEX_INTERPNORMAL 9
70 #define LEX_INTERPCASEMOD 8
71 #define LEX_INTERPPUSH 7
72 #define LEX_INTERPSTART 6
73 #define LEX_INTERPEND 5
74 #define LEX_INTERPENDMAYBE 4
75 #define LEX_INTERPCONCAT 3
76 #define LEX_INTERPCONST 2
77 #define LEX_FORMLINE 1
78 #define LEX_KNOWNEXT 0
87 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
89 # include <unistd.h> /* Needed for execv() */
102 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
104 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
105 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
106 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
107 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
108 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
109 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
110 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
111 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
112 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
113 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
114 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
115 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
116 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
117 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
118 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
119 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
120 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
121 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
122 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
123 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
125 /* This bit of chicanery makes a unary function followed by
126 * a parenthesis into a function with one argument, highest precedence.
128 #define UNI(f) return(yylval.ival = f, \
131 PL_last_uni = PL_oldbufptr, \
132 PL_last_lop_op = f, \
133 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
135 #define UNIBRACK(f) return(yylval.ival = f, \
137 PL_last_uni = PL_oldbufptr, \
138 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
140 /* grandfather return to old style */
141 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
146 if (*PL_bufptr == '=') {
148 if (toketype == ANDAND)
149 yylval.ival = OP_ANDASSIGN;
150 else if (toketype == OROR)
151 yylval.ival = OP_ORASSIGN;
158 no_op(char *what, char *s)
160 char *oldbp = PL_bufptr;
161 bool is_first = (PL_oldbufptr == PL_linestart);
164 yywarn(form("%s found where operator expected", what));
166 warn("\t(Missing semicolon on previous line?)\n");
167 else if (PL_oldoldbufptr && isIDFIRST(*PL_oldoldbufptr)) {
169 for (t = PL_oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
170 if (t < PL_bufptr && isSPACE(*t))
171 warn("\t(Do you need to predeclare %.*s?)\n",
172 t - PL_oldoldbufptr, PL_oldoldbufptr);
176 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
186 char *nl = strrchr(s,'\n');
192 iscntrl(PL_multi_close)
194 PL_multi_close < 32 || PL_multi_close == 127
198 tmpbuf[1] = toCTRL(PL_multi_close);
204 *tmpbuf = PL_multi_close;
208 q = strchr(s,'"') ? '\'' : '"';
209 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
215 if (ckWARN(WARN_DEPRECATED))
216 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
222 deprecate("comma-less variable list");
228 win32_textfilter(int idx, SV *sv, int maxlen)
230 I32 count = FILTER_READ(idx+1, sv, maxlen);
231 if (count > 0 && !maxlen)
232 win32_strip_return(sv);
238 utf16_textfilter(int idx, SV *sv, int maxlen)
240 I32 count = FILTER_READ(idx+1, sv, maxlen);
244 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, char);
245 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
246 sv_usepvn(sv, tmps, tend - tmps);
253 utf16rev_textfilter(int idx, SV *sv, int maxlen)
255 I32 count = FILTER_READ(idx+1, sv, maxlen);
259 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, char);
260 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
261 sv_usepvn(sv, tmps, tend - tmps);
274 SAVEI32(PL_lex_dojoin);
275 SAVEI32(PL_lex_brackets);
276 SAVEI32(PL_lex_fakebrack);
277 SAVEI32(PL_lex_casemods);
278 SAVEI32(PL_lex_starts);
279 SAVEI32(PL_lex_state);
280 SAVESPTR(PL_lex_inpat);
281 SAVEI32(PL_lex_inwhat);
282 SAVEI16(PL_curcop->cop_line);
285 SAVEPPTR(PL_oldbufptr);
286 SAVEPPTR(PL_oldoldbufptr);
287 SAVEPPTR(PL_linestart);
288 SAVESPTR(PL_linestr);
289 SAVEPPTR(PL_lex_brackstack);
290 SAVEPPTR(PL_lex_casestack);
291 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
292 SAVESPTR(PL_lex_stuff);
293 SAVEI32(PL_lex_defer);
294 SAVESPTR(PL_lex_repl);
295 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
296 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
298 PL_lex_state = LEX_NORMAL;
302 PL_lex_fakebrack = 0;
303 New(899, PL_lex_brackstack, 120, char);
304 New(899, PL_lex_casestack, 12, char);
305 SAVEFREEPV(PL_lex_brackstack);
306 SAVEFREEPV(PL_lex_casestack);
308 *PL_lex_casestack = '\0';
311 PL_lex_stuff = Nullsv;
312 PL_lex_repl = Nullsv;
316 if (SvREADONLY(PL_linestr))
317 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
318 s = SvPV(PL_linestr, len);
319 if (len && s[len-1] != ';') {
320 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
321 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
322 sv_catpvn(PL_linestr, "\n;", 2);
324 SvTEMP_off(PL_linestr);
325 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
326 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
328 PL_rs = newSVpv("\n", 1);
335 PL_doextract = FALSE;
339 restore_rsfp(void *f)
341 PerlIO *fp = (PerlIO*)f;
343 if (PL_rsfp == PerlIO_stdin())
344 PerlIO_clearerr(PL_rsfp);
345 else if (PL_rsfp && (PL_rsfp != fp))
346 PerlIO_close(PL_rsfp);
351 restore_expect(void *e)
353 /* a safe way to store a small integer in a pointer */
354 PL_expect = (expectation)((char *)e - PL_tokenbuf);
358 restore_lex_expect(void *e)
360 /* a safe way to store a small integer in a pointer */
361 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
373 PL_curcop->cop_line++;
376 while (*s == ' ' || *s == '\t') s++;
377 if (strnEQ(s, "line ", 5)) {
386 while (*s == ' ' || *s == '\t')
388 if (*s == '"' && (t = strchr(s+1, '"')))
392 return; /* false alarm */
393 for (t = s; !isSPACE(*t); t++) ;
398 PL_curcop->cop_filegv = gv_fetchfile(s);
400 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
402 PL_curcop->cop_line = atoi(n)-1;
406 skipspace(register char *s)
409 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
410 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
416 while (s < PL_bufend && isSPACE(*s))
418 if (s < PL_bufend && *s == '#') {
419 while (s < PL_bufend && *s != '\n')
424 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
426 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
427 if (PL_minus_n || PL_minus_p) {
428 sv_setpv(PL_linestr,PL_minus_p ?
429 ";}continue{print or die qq(-p destination: $!\\n)" :
431 sv_catpv(PL_linestr,";}");
432 PL_minus_n = PL_minus_p = 0;
435 sv_setpv(PL_linestr,";");
436 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
437 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
438 if (PL_preprocess && !PL_in_eval)
439 (void)PerlProc_pclose(PL_rsfp);
440 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
441 PerlIO_clearerr(PL_rsfp);
443 (void)PerlIO_close(PL_rsfp);
447 PL_linestart = PL_bufptr = s + prevlen;
448 PL_bufend = s + SvCUR(PL_linestr);
451 if (PERLDB_LINE && PL_curstash != PL_debstash) {
452 SV *sv = NEWSV(85,0);
454 sv_upgrade(sv, SVt_PVMG);
455 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
456 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
467 if (PL_oldoldbufptr != PL_last_uni)
469 while (isSPACE(*PL_last_uni))
471 for (s = PL_last_uni; isALNUM(*s) || *s == '-'; s++) ;
472 if ((t = strchr(s, '(')) && t < PL_bufptr)
476 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
483 #define UNI(f) return uni(f,s)
491 PL_last_uni = PL_oldbufptr;
502 #endif /* CRIPPLED_CC */
504 #define LOP(f,x) return lop(f,x,s)
507 lop(I32 f, expectation x, char *s)
514 PL_last_lop = PL_oldbufptr;
530 PL_nexttype[PL_nexttoke] = type;
532 if (PL_lex_state != LEX_KNOWNEXT) {
533 PL_lex_defer = PL_lex_state;
534 PL_lex_expect = PL_expect;
535 PL_lex_state = LEX_KNOWNEXT;
540 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
545 start = skipspace(start);
548 (allow_pack && *s == ':') ||
549 (allow_initial_tick && *s == '\'') )
551 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
552 if (check_keyword && keyword(PL_tokenbuf, len))
554 if (token == METHOD) {
559 PL_expect = XOPERATOR;
564 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
565 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
572 force_ident(register char *s, int kind)
575 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
576 PL_nextval[PL_nexttoke].opval = o;
579 dTHR; /* just for in_eval */
580 o->op_private = OPpCONST_ENTERED;
581 /* XXX see note in pp_entereval() for why we forgo typo
582 warnings if the symbol must be introduced in an eval.
584 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
585 kind == '$' ? SVt_PV :
586 kind == '@' ? SVt_PVAV :
587 kind == '%' ? SVt_PVHV :
595 force_version(char *s)
597 OP *version = Nullop;
601 /* default VERSION number -- GBARR */
606 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
607 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
609 /* real VERSION number -- GBARR */
610 version = yylval.opval;
614 /* NOTE: The parser sees the package name and the VERSION swapped */
615 PL_nextval[PL_nexttoke].opval = version;
633 s = SvPV_force(sv, len);
637 while (s < send && *s != '\\')
642 if ( PL_hints & HINT_NEW_STRING )
643 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
646 if (s + 1 < send && (s[1] == '\\'))
647 s++; /* all that, just for this */
652 SvCUR_set(sv, d - SvPVX(sv));
654 if ( PL_hints & HINT_NEW_STRING )
655 return new_constant(NULL, 0, "q", sv, pv, "q");
662 register I32 op_type = yylval.ival;
664 if (op_type == OP_NULL) {
665 yylval.opval = PL_lex_op;
669 if (op_type == OP_CONST || op_type == OP_READLINE) {
670 SV *sv = tokeq(PL_lex_stuff);
672 if (SvTYPE(sv) == SVt_PVIV) {
673 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
679 nsv = newSVpv(p, len);
683 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
684 PL_lex_stuff = Nullsv;
688 PL_sublex_info.super_state = PL_lex_state;
689 PL_sublex_info.sub_inwhat = op_type;
690 PL_sublex_info.sub_op = PL_lex_op;
691 PL_lex_state = LEX_INTERPPUSH;
695 yylval.opval = PL_lex_op;
709 PL_lex_state = PL_sublex_info.super_state;
710 SAVEI32(PL_lex_dojoin);
711 SAVEI32(PL_lex_brackets);
712 SAVEI32(PL_lex_fakebrack);
713 SAVEI32(PL_lex_casemods);
714 SAVEI32(PL_lex_starts);
715 SAVEI32(PL_lex_state);
716 SAVESPTR(PL_lex_inpat);
717 SAVEI32(PL_lex_inwhat);
718 SAVEI16(PL_curcop->cop_line);
720 SAVEPPTR(PL_oldbufptr);
721 SAVEPPTR(PL_oldoldbufptr);
722 SAVEPPTR(PL_linestart);
723 SAVESPTR(PL_linestr);
724 SAVEPPTR(PL_lex_brackstack);
725 SAVEPPTR(PL_lex_casestack);
727 PL_linestr = PL_lex_stuff;
728 PL_lex_stuff = Nullsv;
730 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
731 PL_bufend += SvCUR(PL_linestr);
732 SAVEFREESV(PL_linestr);
734 PL_lex_dojoin = FALSE;
736 PL_lex_fakebrack = 0;
737 New(899, PL_lex_brackstack, 120, char);
738 New(899, PL_lex_casestack, 12, char);
739 SAVEFREEPV(PL_lex_brackstack);
740 SAVEFREEPV(PL_lex_casestack);
742 *PL_lex_casestack = '\0';
744 PL_lex_state = LEX_INTERPCONCAT;
745 PL_curcop->cop_line = PL_multi_start;
747 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
748 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
749 PL_lex_inpat = PL_sublex_info.sub_op;
751 PL_lex_inpat = Nullop;
759 if (!PL_lex_starts++) {
760 PL_expect = XOPERATOR;
761 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
765 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
766 PL_lex_state = LEX_INTERPCASEMOD;
770 /* Is there a right-hand side to take care of? */
771 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
772 PL_linestr = PL_lex_repl;
774 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
775 PL_bufend += SvCUR(PL_linestr);
776 SAVEFREESV(PL_linestr);
777 PL_lex_dojoin = FALSE;
779 PL_lex_fakebrack = 0;
781 *PL_lex_casestack = '\0';
783 if (SvCOMPILED(PL_lex_repl)) {
784 PL_lex_state = LEX_INTERPNORMAL;
788 PL_lex_state = LEX_INTERPCONCAT;
789 PL_lex_repl = Nullsv;
794 PL_bufend = SvPVX(PL_linestr);
795 PL_bufend += SvCUR(PL_linestr);
796 PL_expect = XOPERATOR;
804 Extracts a pattern, double-quoted string, or transliteration. This
807 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
808 processing a pattern (PL_lex_inpat is true), a transliteration
809 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
811 Returns a pointer to the character scanned up to. Iff this is
812 advanced from the start pointer supplied (ie if anything was
813 successfully parsed), will leave an OP for the substring scanned
814 in yylval. Caller must intuit reason for not parsing further
815 by looking at the next characters herself.
819 double-quoted style: \r and \n
820 regexp special ones: \D \s
822 backrefs: \1 (deprecated in substitution replacements)
823 case and quoting: \U \Q \E
824 stops on @ and $, but not for $ as tail anchor
827 characters are VERY literal, except for - not at the start or end
828 of the string, which indicates a range. scan_const expands the
829 range to the full set of intermediate characters.
831 In double-quoted strings:
833 double-quoted style: \r and \n
835 backrefs: \1 (deprecated)
836 case and quoting: \U \Q \E
839 scan_const does *not* construct ops to handle interpolated strings.
840 It stops processing as soon as it finds an embedded $ or @ variable
841 and leaves it to the caller to work out what's going on.
843 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
845 $ in pattern could be $foo or could be tail anchor. Assumption:
846 it's a tail anchor if $ is the last thing in the string, or if it's
847 followed by one of ")| \n\t"
849 \1 (backreferences) are turned into $1
851 The structure of the code is
852 while (there's a character to process) {
853 handle transliteration ranges
855 skip # initiated comments in //x patterns
856 check for embedded @foo
857 check for embedded scalars
859 leave intact backslashes from leave (below)
860 deprecate \1 in strings and sub replacements
861 handle string-changing backslashes \l \U \Q \E, etc.
862 switch (what was escaped) {
863 handle - in a transliteration (becomes a literal -)
864 handle \132 octal characters
865 handle 0x15 hex characters
866 handle \cV (control V)
867 handle printf backslashes (\f, \r, \n, etc)
870 } (end while character to read)
875 scan_const(char *start)
877 register char *send = PL_bufend; /* end of the constant */
878 SV *sv = NEWSV(93, send - start); /* sv for the constant */
879 register char *s = start; /* start of the constant */
880 register char *d = SvPVX(sv); /* destination for copies */
881 bool dorange = FALSE; /* are we in a translit range? */
883 I32 utf = PL_lex_inwhat == OP_TRANS
884 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
886 I32 thisutf = PL_lex_inwhat == OP_TRANS
887 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
890 /* leaveit is the set of acceptably-backslashed characters */
893 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
896 while (s < send || dorange) {
897 /* get transliterations out of the way (they're most literal) */
898 if (PL_lex_inwhat == OP_TRANS) {
899 /* expand a range A-Z to the full set of characters. AIE! */
901 I32 i; /* current expanded character */
902 I32 max; /* last character in range */
904 i = d - SvPVX(sv); /* remember current offset */
905 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
906 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
907 d -= 2; /* eat the first char and the - */
909 max = (U8)d[1]; /* last char in range */
911 for (i = (U8)*d; i <= max; i++)
914 /* mark the range as done, and continue */
919 /* range begins (ignore - as first or last char) */
920 else if (*s == '-' && s+1 < send && s != start) {
922 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
931 /* if we get here, we're not doing a transliteration */
933 /* skip for regexp comments /(?#comment)/ */
934 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
936 while (s < send && *s != ')')
938 } else if (s[2] == '{') { /* This should march regcomp.c */
940 char *regparse = s + 3;
943 while (count && (c = *regparse)) {
944 if (c == '\\' && regparse[1])
952 if (*regparse == ')')
955 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
956 while (s < regparse && *s != ')')
961 /* likewise skip #-initiated comments in //x patterns */
962 else if (*s == '#' && PL_lex_inpat &&
963 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
964 while (s+1 < send && *s != '\n')
968 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
969 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
972 /* check for embedded scalars. only stop if we're sure it's a
975 else if (*s == '$') {
976 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
978 if (s + 1 < send && !strchr("()| \n\t", s[1]))
979 break; /* in regexp, $ might be tail anchor */
982 /* (now in tr/// code again) */
984 if (*s & 0x80 && ckWARN(WARN_UTF8) && thisutf) {
985 (void)utf8_to_uv(s, &len); /* could cvt latin-1 to utf8 here... */
994 if (*s == '\\' && s+1 < send) {
997 /* some backslashes we leave behind */
998 if (*s && strchr(leaveit, *s)) {
1004 /* deprecate \1 in strings and substitution replacements */
1005 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1006 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1008 if (ckWARN(WARN_SYNTAX))
1009 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1014 /* string-change backslash escapes */
1015 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1020 /* if we get here, it's either a quoted -, or a digit */
1023 /* quoted - in transliterations */
1025 if (PL_lex_inwhat == OP_TRANS) {
1030 /* default action is to copy the quoted character */
1035 /* \132 indicates an octal constant */
1036 case '0': case '1': case '2': case '3':
1037 case '4': case '5': case '6': case '7':
1038 *d++ = scan_oct(s, 3, &len);
1042 /* \x24 indicates a hex constant */
1046 char* e = strchr(s, '}');
1049 yyerror("Missing right brace on \\x{}");
1050 if (ckWARN(WARN_UTF8) && !utf)
1051 warner(WARN_UTF8,"Use of \\x{} without utf8 declaration");
1052 /* note: utf always shorter than hex */
1053 d = uv_to_utf8(d, scan_hex(s + 1, e - s - 1, &len));
1058 UV uv = (UV)scan_hex(s, 2, &len);
1059 if (utf && PL_lex_inwhat == OP_TRANS &&
1060 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1062 d = uv_to_utf8(d, uv); /* doing a CU or UC */
1065 if (ckWARN(WARN_UTF8) && uv >= 127 && UTF)
1067 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1075 /* \c is a control character */
1089 /* printf-style backslashes, formfeeds, newlines, etc */
1115 } /* end if (backslash) */
1118 } /* while loop to process each character */
1120 /* terminate the string and set up the sv */
1122 SvCUR_set(sv, d - SvPVX(sv));
1125 /* shrink the sv if we allocated more than we used */
1126 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1127 SvLEN_set(sv, SvCUR(sv) + 1);
1128 Renew(SvPVX(sv), SvLEN(sv), char);
1131 /* return the substring (via yylval) only if we parsed anything */
1132 if (s > PL_bufptr) {
1133 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1134 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1136 ( PL_lex_inwhat == OP_TRANS
1138 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1141 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1147 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1149 intuit_more(register char *s)
1151 if (PL_lex_brackets)
1153 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1155 if (*s != '{' && *s != '[')
1160 /* In a pattern, so maybe we have {n,m}. */
1177 /* On the other hand, maybe we have a character class */
1180 if (*s == ']' || *s == '^')
1183 int weight = 2; /* let's weigh the evidence */
1185 unsigned char un_char = 255, last_un_char;
1186 char *send = strchr(s,']');
1187 char tmpbuf[sizeof PL_tokenbuf * 4];
1189 if (!send) /* has to be an expression */
1192 Zero(seen,256,char);
1195 else if (isDIGIT(*s)) {
1197 if (isDIGIT(s[1]) && s[2] == ']')
1203 for (; s < send; s++) {
1204 last_un_char = un_char;
1205 un_char = (unsigned char)*s;
1210 weight -= seen[un_char] * 10;
1211 if (isALNUM(s[1])) {
1212 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1213 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1218 else if (*s == '$' && s[1] &&
1219 strchr("[#!%*<>()-=",s[1])) {
1220 if (/*{*/ strchr("])} =",s[2]))
1229 if (strchr("wds]",s[1]))
1231 else if (seen['\''] || seen['"'])
1233 else if (strchr("rnftbxcav",s[1]))
1235 else if (isDIGIT(s[1])) {
1237 while (s[1] && isDIGIT(s[1]))
1247 if (strchr("aA01! ",last_un_char))
1249 if (strchr("zZ79~",s[1]))
1251 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1252 weight -= 5; /* cope with negative subscript */
1255 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1256 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1261 if (keyword(tmpbuf, d - tmpbuf))
1264 if (un_char == last_un_char + 1)
1266 weight -= seen[un_char];
1271 if (weight >= 0) /* probably a character class */
1279 intuit_method(char *start, GV *gv)
1281 char *s = start + (*start == '$');
1282 char tmpbuf[sizeof PL_tokenbuf];
1290 if ((cv = GvCVu(gv))) {
1291 char *proto = SvPVX(cv);
1301 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1302 if (*start == '$') {
1303 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1308 return *s == '(' ? FUNCMETH : METHOD;
1310 if (!keyword(tmpbuf, len)) {
1311 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1316 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1317 if (indirgv && GvCVu(indirgv))
1319 /* filehandle or package name makes it a method */
1320 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1322 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1323 return 0; /* no assumptions -- "=>" quotes bearword */
1325 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1327 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1331 return *s == '(' ? FUNCMETH : METHOD;
1341 char *pdb = PerlEnv_getenv("PERL5DB");
1345 SETERRNO(0,SS$_NORMAL);
1346 return "BEGIN { require 'perl5db.pl' }";
1352 /* Encoded script support. filter_add() effectively inserts a
1353 * 'pre-processing' function into the current source input stream.
1354 * Note that the filter function only applies to the current source file
1355 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1357 * The datasv parameter (which may be NULL) can be used to pass
1358 * private data to this instance of the filter. The filter function
1359 * can recover the SV using the FILTER_DATA macro and use it to
1360 * store private buffers and state information.
1362 * The supplied datasv parameter is upgraded to a PVIO type
1363 * and the IoDIRP field is used to store the function pointer.
1364 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1365 * private use must be set using malloc'd pointers.
1367 static int filter_debug = 0;
1370 filter_add(filter_t funcp, SV *datasv)
1372 if (!funcp){ /* temporary handy debugging hack to be deleted */
1373 filter_debug = atoi((char*)datasv);
1376 if (!PL_rsfp_filters)
1377 PL_rsfp_filters = newAV();
1379 datasv = NEWSV(255,0);
1380 if (!SvUPGRADE(datasv, SVt_PVIO))
1381 die("Can't upgrade filter_add data to SVt_PVIO");
1382 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1384 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1385 av_unshift(PL_rsfp_filters, 1);
1386 av_store(PL_rsfp_filters, 0, datasv) ;
1391 /* Delete most recently added instance of this filter function. */
1393 filter_del(filter_t funcp)
1396 warn("filter_del func %p", funcp);
1397 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1399 /* if filter is on top of stack (usual case) just pop it off */
1400 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (void*)funcp){
1401 sv_free(av_pop(PL_rsfp_filters));
1405 /* we need to search for the correct entry and clear it */
1406 die("filter_del can only delete in reverse order (currently)");
1410 /* Invoke the n'th filter function for the current rsfp. */
1412 filter_read(int idx, SV *buf_sv, int maxlen)
1415 /* 0 = read one text line */
1420 if (!PL_rsfp_filters)
1422 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1423 /* Provide a default input filter to make life easy. */
1424 /* Note that we append to the line. This is handy. */
1426 warn("filter_read %d: from rsfp\n", idx);
1430 int old_len = SvCUR(buf_sv) ;
1432 /* ensure buf_sv is large enough */
1433 SvGROW(buf_sv, old_len + maxlen) ;
1434 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1435 if (PerlIO_error(PL_rsfp))
1436 return -1; /* error */
1438 return 0 ; /* end of file */
1440 SvCUR_set(buf_sv, old_len + len) ;
1443 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1444 if (PerlIO_error(PL_rsfp))
1445 return -1; /* error */
1447 return 0 ; /* end of file */
1450 return SvCUR(buf_sv);
1452 /* Skip this filter slot if filter has been deleted */
1453 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1455 warn("filter_read %d: skipped (filter deleted)\n", idx);
1456 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1458 /* Get function pointer hidden within datasv */
1459 funcp = (filter_t)IoDIRP(datasv);
1461 warn("filter_read %d: via function %p (%s)\n",
1462 idx, funcp, SvPV(datasv,PL_na));
1463 /* Call function. The function is expected to */
1464 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1465 /* Return: <0:error, =0:eof, >0:not eof */
1466 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1470 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1473 if (!PL_rsfp_filters) {
1474 filter_add(win32_textfilter,NULL);
1477 if (PL_rsfp_filters) {
1480 SvCUR_set(sv, 0); /* start with empty line */
1481 if (FILTER_READ(0, sv, 0) > 0)
1482 return ( SvPVX(sv) ) ;
1487 return (sv_gets(sv, fp, append));
1492 static char* exp_name[] =
1493 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1496 EXT int yychar; /* last token */
1501 Works out what to call the token just pulled out of the input
1502 stream. The yacc parser takes care of taking the ops we return and
1503 stitching them into a tree.
1509 if read an identifier
1510 if we're in a my declaration
1511 croak if they tried to say my($foo::bar)
1512 build the ops for a my() declaration
1513 if it's an access to a my() variable
1514 are we in a sort block?
1515 croak if my($a); $a <=> $b
1516 build ops for access to a my() variable
1517 if in a dq string, and they've said @foo and we can't find @foo
1519 build ops for a bareword
1520 if we already built the token before, use it.
1534 /* check if there's an identifier for us to look at */
1535 if (PL_pending_ident) {
1536 /* pit holds the identifier we read and pending_ident is reset */
1537 char pit = PL_pending_ident;
1538 PL_pending_ident = 0;
1540 /* if we're in a my(), we can't allow dynamics here.
1541 $foo'bar has already been turned into $foo::bar, so
1542 just check for colons.
1544 if it's a legal name, the OP is a PADANY.
1547 if (strchr(PL_tokenbuf,':'))
1548 croak(no_myglob,PL_tokenbuf);
1550 yylval.opval = newOP(OP_PADANY, 0);
1551 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1556 build the ops for accesses to a my() variable.
1558 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1559 then used in a comparison. This catches most, but not
1560 all cases. For instance, it catches
1561 sort { my($a); $a <=> $b }
1563 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1564 (although why you'd do that is anyone's guess).
1567 if (!strchr(PL_tokenbuf,':')) {
1569 /* Check for single character per-thread SVs */
1570 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1571 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1572 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1574 yylval.opval = newOP(OP_THREADSV, 0);
1575 yylval.opval->op_targ = tmp;
1578 #endif /* USE_THREADS */
1579 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1580 /* if it's a sort block and they're naming $a or $b */
1581 if (PL_last_lop_op == OP_SORT &&
1582 PL_tokenbuf[0] == '$' &&
1583 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1586 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1587 d < PL_bufend && *d != '\n';
1590 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1591 croak("Can't use \"my %s\" in sort comparison",
1597 yylval.opval = newOP(OP_PADANY, 0);
1598 yylval.opval->op_targ = tmp;
1604 Whine if they've said @foo in a doublequoted string,
1605 and @foo isn't a variable we can find in the symbol
1608 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1609 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1610 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1611 yyerror(form("In string, %s now must be written as \\%s",
1612 PL_tokenbuf, PL_tokenbuf));
1615 /* build ops for a bareword */
1616 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1617 yylval.opval->op_private = OPpCONST_ENTERED;
1618 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1619 ((PL_tokenbuf[0] == '$') ? SVt_PV
1620 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1625 /* no identifier pending identification */
1627 switch (PL_lex_state) {
1629 case LEX_NORMAL: /* Some compilers will produce faster */
1630 case LEX_INTERPNORMAL: /* code if we comment these out. */
1634 /* when we're already built the next token, just pull it out the queue */
1637 yylval = PL_nextval[PL_nexttoke];
1639 PL_lex_state = PL_lex_defer;
1640 PL_expect = PL_lex_expect;
1641 PL_lex_defer = LEX_NORMAL;
1643 return(PL_nexttype[PL_nexttoke]);
1645 /* interpolated case modifiers like \L \U, including \Q and \E.
1646 when we get here, PL_bufptr is at the \
1648 case LEX_INTERPCASEMOD:
1650 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1651 croak("panic: INTERPCASEMOD");
1653 /* handle \E or end of string */
1654 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1658 if (PL_lex_casemods) {
1659 oldmod = PL_lex_casestack[--PL_lex_casemods];
1660 PL_lex_casestack[PL_lex_casemods] = '\0';
1662 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1664 PL_lex_state = LEX_INTERPCONCAT;
1668 if (PL_bufptr != PL_bufend)
1670 PL_lex_state = LEX_INTERPCONCAT;
1675 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1676 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1677 if (strchr("LU", *s) &&
1678 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1680 PL_lex_casestack[--PL_lex_casemods] = '\0';
1683 if (PL_lex_casemods > 10) {
1684 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1685 if (newlb != PL_lex_casestack) {
1687 PL_lex_casestack = newlb;
1690 PL_lex_casestack[PL_lex_casemods++] = *s;
1691 PL_lex_casestack[PL_lex_casemods] = '\0';
1692 PL_lex_state = LEX_INTERPCONCAT;
1693 PL_nextval[PL_nexttoke].ival = 0;
1696 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1698 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1700 PL_nextval[PL_nexttoke].ival = OP_LC;
1702 PL_nextval[PL_nexttoke].ival = OP_UC;
1704 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1706 croak("panic: yylex");
1709 if (PL_lex_starts) {
1718 case LEX_INTERPPUSH:
1719 return sublex_push();
1721 case LEX_INTERPSTART:
1722 if (PL_bufptr == PL_bufend)
1723 return sublex_done();
1725 PL_lex_dojoin = (*PL_bufptr == '@');
1726 PL_lex_state = LEX_INTERPNORMAL;
1727 if (PL_lex_dojoin) {
1728 PL_nextval[PL_nexttoke].ival = 0;
1731 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1732 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1733 force_next(PRIVATEREF);
1735 force_ident("\"", '$');
1736 #endif /* USE_THREADS */
1737 PL_nextval[PL_nexttoke].ival = 0;
1739 PL_nextval[PL_nexttoke].ival = 0;
1741 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1744 if (PL_lex_starts++) {
1750 case LEX_INTERPENDMAYBE:
1751 if (intuit_more(PL_bufptr)) {
1752 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1758 if (PL_lex_dojoin) {
1759 PL_lex_dojoin = FALSE;
1760 PL_lex_state = LEX_INTERPCONCAT;
1764 case LEX_INTERPCONCAT:
1766 if (PL_lex_brackets)
1767 croak("panic: INTERPCONCAT");
1769 if (PL_bufptr == PL_bufend)
1770 return sublex_done();
1772 if (SvIVX(PL_linestr) == '\'') {
1773 SV *sv = newSVsv(PL_linestr);
1776 else if ( PL_hints & HINT_NEW_RE )
1777 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1778 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1782 s = scan_const(PL_bufptr);
1784 PL_lex_state = LEX_INTERPCASEMOD;
1786 PL_lex_state = LEX_INTERPSTART;
1789 if (s != PL_bufptr) {
1790 PL_nextval[PL_nexttoke] = yylval;
1793 if (PL_lex_starts++)
1803 PL_lex_state = LEX_NORMAL;
1804 s = scan_formline(PL_bufptr);
1805 if (!PL_lex_formbrack)
1811 PL_oldoldbufptr = PL_oldbufptr;
1814 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1821 * Note: we try to be careful never to call the isXXX_utf8() functions unless we're
1822 * pretty sure we've seen the beginning of a UTF-8 character (that is, the two high
1823 * bits are set). Otherwise we risk loading in the heavy-duty SWASHINIT and SWASHGET
1824 * routines unnecessarily. You will see this not just here but throughout this file.
1826 if (UTF && (*s & 0xc0) == 0x80) {
1827 if (isIDFIRST_utf8(s))
1830 croak("Unrecognized character \\x%02X", *s & 255);
1833 goto fake_eof; /* emulate EOF on ^D or ^Z */
1838 if (PL_lex_brackets)
1839 yyerror("Missing right bracket");
1842 if (s++ < PL_bufend)
1843 goto retry; /* ignore stray nulls */
1846 if (!PL_in_eval && !PL_preambled) {
1847 PL_preambled = TRUE;
1848 sv_setpv(PL_linestr,incl_perldb());
1849 if (SvCUR(PL_linestr))
1850 sv_catpv(PL_linestr,";");
1852 while(AvFILLp(PL_preambleav) >= 0) {
1853 SV *tmpsv = av_shift(PL_preambleav);
1854 sv_catsv(PL_linestr, tmpsv);
1855 sv_catpv(PL_linestr, ";");
1858 sv_free((SV*)PL_preambleav);
1859 PL_preambleav = NULL;
1861 if (PL_minus_n || PL_minus_p) {
1862 sv_catpv(PL_linestr, "LINE: while (<>) {");
1864 sv_catpv(PL_linestr,"chomp;");
1866 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1868 GvIMPORTED_AV_on(gv);
1870 if (strchr("/'\"", *PL_splitstr)
1871 && strchr(PL_splitstr + 1, *PL_splitstr))
1872 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1875 s = "'~#\200\1'"; /* surely one char is unused...*/
1876 while (s[1] && strchr(PL_splitstr, *s)) s++;
1878 sv_catpvf(PL_linestr, "@F=split(%s%c",
1879 "q" + (delim == '\''), delim);
1880 for (s = PL_splitstr; *s; s++) {
1882 sv_catpvn(PL_linestr, "\\", 1);
1883 sv_catpvn(PL_linestr, s, 1);
1885 sv_catpvf(PL_linestr, "%c);", delim);
1889 sv_catpv(PL_linestr,"@F=split(' ');");
1892 sv_catpv(PL_linestr, "\n");
1893 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1894 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1895 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1896 SV *sv = NEWSV(85,0);
1898 sv_upgrade(sv, SVt_PVMG);
1899 sv_setsv(sv,PL_linestr);
1900 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1905 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1908 if (PL_preprocess && !PL_in_eval)
1909 (void)PerlProc_pclose(PL_rsfp);
1910 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1911 PerlIO_clearerr(PL_rsfp);
1913 (void)PerlIO_close(PL_rsfp);
1915 PL_doextract = FALSE;
1917 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1918 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1919 sv_catpv(PL_linestr,";}");
1920 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1921 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1922 PL_minus_n = PL_minus_p = 0;
1925 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1926 sv_setpv(PL_linestr,"");
1927 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1930 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1931 PL_doextract = FALSE;
1933 /* Incest with pod. */
1934 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1935 sv_setpv(PL_linestr, "");
1936 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1937 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1938 PL_doextract = FALSE;
1942 } while (PL_doextract);
1943 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1944 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1945 SV *sv = NEWSV(85,0);
1947 sv_upgrade(sv, SVt_PVMG);
1948 sv_setsv(sv,PL_linestr);
1949 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1951 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1952 if (PL_curcop->cop_line == 1) {
1953 while (s < PL_bufend && isSPACE(*s))
1955 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1959 if (*s == '#' && *(s+1) == '!')
1961 #ifdef ALTERNATE_SHEBANG
1963 static char as[] = ALTERNATE_SHEBANG;
1964 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1965 d = s + (sizeof(as) - 1);
1967 #endif /* ALTERNATE_SHEBANG */
1976 while (*d && !isSPACE(*d))
1980 #ifdef ARG_ZERO_IS_SCRIPT
1981 if (ipathend > ipath) {
1983 * HP-UX (at least) sets argv[0] to the script name,
1984 * which makes $^X incorrect. And Digital UNIX and Linux,
1985 * at least, set argv[0] to the basename of the Perl
1986 * interpreter. So, having found "#!", we'll set it right.
1988 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1989 assert(SvPOK(x) || SvGMAGICAL(x));
1990 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
1991 sv_setpvn(x, ipath, ipathend - ipath);
1994 TAINT_NOT; /* $^X is always tainted, but that's OK */
1996 #endif /* ARG_ZERO_IS_SCRIPT */
2001 d = instr(s,"perl -");
2003 d = instr(s,"perl");
2004 #ifdef ALTERNATE_SHEBANG
2006 * If the ALTERNATE_SHEBANG on this system starts with a
2007 * character that can be part of a Perl expression, then if
2008 * we see it but not "perl", we're probably looking at the
2009 * start of Perl code, not a request to hand off to some
2010 * other interpreter. Similarly, if "perl" is there, but
2011 * not in the first 'word' of the line, we assume the line
2012 * contains the start of the Perl program.
2014 if (d && *s != '#') {
2016 while (*c && !strchr("; \t\r\n\f\v#", *c))
2019 d = Nullch; /* "perl" not in first word; ignore */
2021 *s = '#'; /* Don't try to parse shebang line */
2023 #endif /* ALTERNATE_SHEBANG */
2028 !instr(s,"indir") &&
2029 instr(PL_origargv[0],"perl"))
2035 while (s < PL_bufend && isSPACE(*s))
2037 if (s < PL_bufend) {
2038 Newz(899,newargv,PL_origargc+3,char*);
2040 while (s < PL_bufend && !isSPACE(*s))
2043 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2046 newargv = PL_origargv;
2048 execv(ipath, newargv);
2049 croak("Can't exec %s", ipath);
2052 U32 oldpdb = PL_perldb;
2053 bool oldn = PL_minus_n;
2054 bool oldp = PL_minus_p;
2056 while (*d && !isSPACE(*d)) d++;
2057 while (*d == ' ' || *d == '\t') d++;
2061 if (*d == 'M' || *d == 'm') {
2063 while (*d && !isSPACE(*d)) d++;
2064 croak("Too late for \"-%.*s\" option",
2067 d = moreswitches(d);
2069 if (PERLDB_LINE && !oldpdb ||
2070 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2071 /* if we have already added "LINE: while (<>) {",
2072 we must not do it again */
2074 sv_setpv(PL_linestr, "");
2075 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2076 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2077 PL_preambled = FALSE;
2079 (void)gv_fetchfile(PL_origfilename);
2086 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2088 PL_lex_state = LEX_FORMLINE;
2093 #ifdef PERL_STRICT_CR
2094 warn("Illegal character \\%03o (carriage return)", '\r');
2096 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2098 case ' ': case '\t': case '\f': case 013:
2103 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2105 while (s < d && *s != '\n')
2110 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2112 PL_lex_state = LEX_FORMLINE;
2122 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2127 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2130 if (strnEQ(s,"=>",2)) {
2131 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2132 OPERATOR('-'); /* unary minus */
2134 PL_last_uni = PL_oldbufptr;
2135 PL_last_lop_op = OP_FTEREAD; /* good enough */
2137 case 'r': FTST(OP_FTEREAD);
2138 case 'w': FTST(OP_FTEWRITE);
2139 case 'x': FTST(OP_FTEEXEC);
2140 case 'o': FTST(OP_FTEOWNED);
2141 case 'R': FTST(OP_FTRREAD);
2142 case 'W': FTST(OP_FTRWRITE);
2143 case 'X': FTST(OP_FTREXEC);
2144 case 'O': FTST(OP_FTROWNED);
2145 case 'e': FTST(OP_FTIS);
2146 case 'z': FTST(OP_FTZERO);
2147 case 's': FTST(OP_FTSIZE);
2148 case 'f': FTST(OP_FTFILE);
2149 case 'd': FTST(OP_FTDIR);
2150 case 'l': FTST(OP_FTLINK);
2151 case 'p': FTST(OP_FTPIPE);
2152 case 'S': FTST(OP_FTSOCK);
2153 case 'u': FTST(OP_FTSUID);
2154 case 'g': FTST(OP_FTSGID);
2155 case 'k': FTST(OP_FTSVTX);
2156 case 'b': FTST(OP_FTBLK);
2157 case 'c': FTST(OP_FTCHR);
2158 case 't': FTST(OP_FTTTY);
2159 case 'T': FTST(OP_FTTEXT);
2160 case 'B': FTST(OP_FTBINARY);
2161 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2162 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2163 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2165 croak("Unrecognized file test: -%c", (int)tmp);
2172 if (PL_expect == XOPERATOR)
2177 else if (*s == '>') {
2180 if (isIDFIRST(*s)) {
2181 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2189 if (PL_expect == XOPERATOR)
2192 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2194 OPERATOR('-'); /* unary minus */
2201 if (PL_expect == XOPERATOR)
2206 if (PL_expect == XOPERATOR)
2209 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2215 if (PL_expect != XOPERATOR) {
2216 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2217 PL_expect = XOPERATOR;
2218 force_ident(PL_tokenbuf, '*');
2231 if (PL_expect == XOPERATOR) {
2235 PL_tokenbuf[0] = '%';
2236 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2237 if (!PL_tokenbuf[1]) {
2239 yyerror("Final % should be \\% or %name");
2242 PL_pending_ident = '%';
2264 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2265 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2270 if (PL_curcop->cop_line < PL_copline)
2271 PL_copline = PL_curcop->cop_line;
2282 if (PL_lex_brackets <= 0)
2283 yyerror("Unmatched right bracket");
2286 if (PL_lex_state == LEX_INTERPNORMAL) {
2287 if (PL_lex_brackets == 0) {
2288 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2289 PL_lex_state = LEX_INTERPEND;
2296 if (PL_lex_brackets > 100) {
2297 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2298 if (newlb != PL_lex_brackstack) {
2300 PL_lex_brackstack = newlb;
2303 switch (PL_expect) {
2305 if (PL_lex_formbrack) {
2309 if (PL_oldoldbufptr == PL_last_lop)
2310 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2312 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2313 OPERATOR(HASHBRACK);
2315 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2318 PL_tokenbuf[0] = '\0';
2319 if (d < PL_bufend && *d == '-') {
2320 PL_tokenbuf[0] = '-';
2322 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2325 if (d < PL_bufend && isIDFIRST(*d)) {
2326 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2328 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2331 char minus = (PL_tokenbuf[0] == '-');
2332 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2339 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2343 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2348 if (PL_oldoldbufptr == PL_last_lop)
2349 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2351 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2354 OPERATOR(HASHBRACK);
2355 /* This hack serves to disambiguate a pair of curlies
2356 * as being a block or an anon hash. Normally, expectation
2357 * determines that, but in cases where we're not in a
2358 * position to expect anything in particular (like inside
2359 * eval"") we have to resolve the ambiguity. This code
2360 * covers the case where the first term in the curlies is a
2361 * quoted string. Most other cases need to be explicitly
2362 * disambiguated by prepending a `+' before the opening
2363 * curly in order to force resolution as an anon hash.
2365 * XXX should probably propagate the outer expectation
2366 * into eval"" to rely less on this hack, but that could
2367 * potentially break current behavior of eval"".
2371 if (*s == '\'' || *s == '"' || *s == '`') {
2372 /* common case: get past first string, handling escapes */
2373 for (t++; t < PL_bufend && *t != *s;)
2374 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2378 else if (*s == 'q') {
2381 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2382 && !isALNUM(*t)))) {
2384 char open, close, term;
2387 while (t < PL_bufend && isSPACE(*t))
2391 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2395 for (t++; t < PL_bufend; t++) {
2396 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2398 else if (*t == open)
2402 for (t++; t < PL_bufend; t++) {
2403 if (*t == '\\' && t+1 < PL_bufend)
2405 else if (*t == close && --brackets <= 0)
2407 else if (*t == open)
2413 else if (isALPHA(*s)) {
2414 for (t++; t < PL_bufend && isALNUM(*t); t++) ;
2416 while (t < PL_bufend && isSPACE(*t))
2418 /* if comma follows first term, call it an anon hash */
2419 /* XXX it could be a comma expression with loop modifiers */
2420 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2421 || (*t == '=' && t[1] == '>')))
2422 OPERATOR(HASHBRACK);
2423 if (PL_expect == XREF)
2426 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2432 yylval.ival = PL_curcop->cop_line;
2433 if (isSPACE(*s) || *s == '#')
2434 PL_copline = NOLINE; /* invalidate current command line number */
2439 if (PL_lex_brackets <= 0)
2440 yyerror("Unmatched right bracket");
2442 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2443 if (PL_lex_brackets < PL_lex_formbrack)
2444 PL_lex_formbrack = 0;
2445 if (PL_lex_state == LEX_INTERPNORMAL) {
2446 if (PL_lex_brackets == 0) {
2447 if (PL_lex_fakebrack) {
2448 PL_lex_state = LEX_INTERPEND;
2450 return yylex(); /* ignore fake brackets */
2452 if (*s == '-' && s[1] == '>')
2453 PL_lex_state = LEX_INTERPENDMAYBE;
2454 else if (*s != '[' && *s != '{')
2455 PL_lex_state = LEX_INTERPEND;
2458 if (PL_lex_brackets < PL_lex_fakebrack) {
2460 PL_lex_fakebrack = 0;
2461 return yylex(); /* ignore fake brackets */
2471 if (PL_expect == XOPERATOR) {
2472 if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && PL_bufptr == PL_linestart) {
2473 PL_curcop->cop_line--;
2474 warner(WARN_SEMICOLON, warn_nosemi);
2475 PL_curcop->cop_line++;
2480 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2482 PL_expect = XOPERATOR;
2483 force_ident(PL_tokenbuf, '&');
2487 yylval.ival = (OPpENTERSUB_AMPER<<8);
2506 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2507 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2509 if (PL_expect == XSTATE && isALPHA(tmp) &&
2510 (s == PL_linestart+1 || s[-2] == '\n') )
2512 if (PL_in_eval && !PL_rsfp) {
2517 if (strnEQ(s,"=cut",4)) {
2531 PL_doextract = TRUE;
2534 if (PL_lex_brackets < PL_lex_formbrack) {
2536 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2537 if (*t == '\n' || *t == '#') {
2555 if (PL_expect != XOPERATOR) {
2556 if (s[1] != '<' && !strchr(s,'>'))
2559 s = scan_heredoc(s);
2561 s = scan_inputsymbol(s);
2562 TERM(sublex_start());
2567 SHop(OP_LEFT_SHIFT);
2581 SHop(OP_RIGHT_SHIFT);
2590 if (PL_expect == XOPERATOR) {
2591 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2594 return ','; /* grandfather non-comma-format format */
2598 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2599 if (PL_expect == XOPERATOR)
2600 no_op("Array length", PL_bufptr);
2601 PL_tokenbuf[0] = '@';
2602 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2604 if (!PL_tokenbuf[1])
2606 PL_expect = XOPERATOR;
2607 PL_pending_ident = '#';
2611 if (PL_expect == XOPERATOR)
2612 no_op("Scalar", PL_bufptr);
2613 PL_tokenbuf[0] = '$';
2614 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2615 if (!PL_tokenbuf[1]) {
2617 yyerror("Final $ should be \\$ or $name");
2621 /* This kludge not intended to be bulletproof. */
2622 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2623 yylval.opval = newSVOP(OP_CONST, 0,
2624 newSViv((IV)PL_compiling.cop_arybase));
2625 yylval.opval->op_private = OPpCONST_ARYBASE;
2630 if (PL_lex_state == LEX_NORMAL)
2633 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2636 PL_tokenbuf[0] = '@';
2637 if (ckWARN(WARN_SYNTAX)) {
2639 isSPACE(*t) || isALNUM(*t) || *t == '$';
2642 PL_bufptr = skipspace(PL_bufptr);
2643 while (t < PL_bufend && *t != ']')
2646 "Multidimensional syntax %.*s not supported",
2647 (t - PL_bufptr) + 1, PL_bufptr);
2651 else if (*s == '{') {
2652 PL_tokenbuf[0] = '%';
2653 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2654 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2656 char tmpbuf[sizeof PL_tokenbuf];
2658 for (t++; isSPACE(*t); t++) ;
2659 if (isIDFIRST(*t)) {
2660 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2661 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2663 "You need to quote \"%s\"", tmpbuf);
2669 PL_expect = XOPERATOR;
2670 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2671 bool islop = (PL_last_lop == PL_oldoldbufptr);
2672 if (!islop || PL_last_lop_op == OP_GREPSTART)
2673 PL_expect = XOPERATOR;
2674 else if (strchr("$@\"'`q", *s))
2675 PL_expect = XTERM; /* e.g. print $fh "foo" */
2676 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2677 PL_expect = XTERM; /* e.g. print $fh &sub */
2678 else if (isIDFIRST(*s)) {
2679 char tmpbuf[sizeof PL_tokenbuf];
2680 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2681 if (tmp = keyword(tmpbuf, len)) {
2682 /* binary operators exclude handle interpretations */
2694 PL_expect = XTERM; /* e.g. print $fh length() */
2699 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2700 if (gv && GvCVu(gv))
2701 PL_expect = XTERM; /* e.g. print $fh subr() */
2704 else if (isDIGIT(*s))
2705 PL_expect = XTERM; /* e.g. print $fh 3 */
2706 else if (*s == '.' && isDIGIT(s[1]))
2707 PL_expect = XTERM; /* e.g. print $fh .3 */
2708 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2709 PL_expect = XTERM; /* e.g. print $fh -1 */
2710 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2711 PL_expect = XTERM; /* print $fh <<"EOF" */
2713 PL_pending_ident = '$';
2717 if (PL_expect == XOPERATOR)
2719 PL_tokenbuf[0] = '@';
2720 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2721 if (!PL_tokenbuf[1]) {
2723 yyerror("Final @ should be \\@ or @name");
2726 if (PL_lex_state == LEX_NORMAL)
2728 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2730 PL_tokenbuf[0] = '%';
2732 /* Warn about @ where they meant $. */
2733 if (ckWARN(WARN_SYNTAX)) {
2734 if (*s == '[' || *s == '{') {
2736 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2738 if (*t == '}' || *t == ']') {
2740 PL_bufptr = skipspace(PL_bufptr);
2742 "Scalar value %.*s better written as $%.*s",
2743 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2748 PL_pending_ident = '@';
2751 case '/': /* may either be division or pattern */
2752 case '?': /* may either be conditional or pattern */
2753 if (PL_expect != XOPERATOR) {
2754 /* Disable warning on "study /blah/" */
2755 if (PL_oldoldbufptr == PL_last_uni
2756 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2757 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2759 s = scan_pat(s,OP_MATCH);
2760 TERM(sublex_start());
2768 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack && s[1] == '\n' &&
2769 (s == PL_linestart || s[-1] == '\n') ) {
2770 PL_lex_formbrack = 0;
2774 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2780 yylval.ival = OPf_SPECIAL;
2786 if (PL_expect != XOPERATOR)
2791 case '0': case '1': case '2': case '3': case '4':
2792 case '5': case '6': case '7': case '8': case '9':
2794 if (PL_expect == XOPERATOR)
2800 if (PL_expect == XOPERATOR) {
2801 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2804 return ','; /* grandfather non-comma-format format */
2810 missingterm((char*)0);
2811 yylval.ival = OP_CONST;
2812 TERM(sublex_start());
2816 if (PL_expect == XOPERATOR) {
2817 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2820 return ','; /* grandfather non-comma-format format */
2826 missingterm((char*)0);
2827 yylval.ival = OP_CONST;
2828 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2829 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2830 yylval.ival = OP_STRINGIFY;
2834 TERM(sublex_start());
2838 if (PL_expect == XOPERATOR)
2839 no_op("Backticks",s);
2841 missingterm((char*)0);
2842 yylval.ival = OP_BACKTICK;
2844 TERM(sublex_start());
2848 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2849 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2851 if (PL_expect == XOPERATOR)
2852 no_op("Backslash",s);
2856 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2895 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2897 /* Some keywords can be followed by any delimiter, including ':' */
2898 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2899 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2900 (PL_tokenbuf[0] == 'q' &&
2901 strchr("qwxr", PL_tokenbuf[1]))));
2903 /* x::* is just a word, unless x is "CORE" */
2904 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2908 while (d < PL_bufend && isSPACE(*d))
2909 d++; /* no comments skipped here, or s### is misparsed */
2911 /* Is this a label? */
2912 if (!tmp && PL_expect == XSTATE
2913 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2915 yylval.pval = savepv(PL_tokenbuf);
2920 /* Check for keywords */
2921 tmp = keyword(PL_tokenbuf, len);
2923 /* Is this a word before a => operator? */
2924 if (strnEQ(d,"=>",2)) {
2926 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2927 yylval.opval->op_private = OPpCONST_BARE;
2931 if (tmp < 0) { /* second-class keyword? */
2932 GV *ogv = Nullgv; /* override (winner) */
2933 GV *hgv = Nullgv; /* hidden (loser) */
2934 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2936 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
2939 if (GvIMPORTED_CV(gv))
2941 else if (! CvMETHOD(cv))
2945 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2946 (gv = *gvp) != (GV*)&PL_sv_undef &&
2947 GvCVu(gv) && GvIMPORTED_CV(gv))
2953 tmp = 0; /* overridden by import or by GLOBAL */
2956 && -tmp==KEY_lock /* XXX generalizable kludge */
2957 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
2959 tmp = 0; /* any sub overrides "weak" keyword */
2961 else { /* no override */
2965 if (ckWARN(WARN_AMBIGUOUS) && hgv)
2966 warner(WARN_AMBIGUOUS,
2967 "Ambiguous call resolved as CORE::%s(), %s",
2968 GvENAME(hgv), "qualify as such or use &");
2975 default: /* not a keyword */
2978 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
2980 /* Get the rest if it looks like a package qualifier */
2982 if (*s == '\'' || *s == ':' && s[1] == ':') {
2984 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
2987 croak("Bad name after %s%s", PL_tokenbuf,
2988 *s == '\'' ? "'" : "::");
2992 if (PL_expect == XOPERATOR) {
2993 if (PL_bufptr == PL_linestart) {
2994 PL_curcop->cop_line--;
2995 warner(WARN_SEMICOLON, warn_nosemi);
2996 PL_curcop->cop_line++;
2999 no_op("Bareword",s);
3002 /* Look for a subroutine with this name in current package,
3003 unless name is "Foo::", in which case Foo is a bearword
3004 (and a package name). */
3007 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3009 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3011 "Bareword \"%s\" refers to nonexistent package",
3014 PL_tokenbuf[len] = '\0';
3021 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3024 /* if we saw a global override before, get the right name */
3027 sv = newSVpv("CORE::GLOBAL::",14);
3028 sv_catpv(sv,PL_tokenbuf);
3031 sv = newSVpv(PL_tokenbuf,0);
3033 /* Presume this is going to be a bareword of some sort. */
3036 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3037 yylval.opval->op_private = OPpCONST_BARE;
3039 /* And if "Foo::", then that's what it certainly is. */
3044 /* See if it's the indirect object for a list operator. */
3046 if (PL_oldoldbufptr &&
3047 PL_oldoldbufptr < PL_bufptr &&
3048 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3049 /* NO SKIPSPACE BEFORE HERE! */
3051 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3052 || (PL_last_lop_op == OP_ENTERSUB
3054 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3056 bool immediate_paren = *s == '(';
3058 /* (Now we can afford to cross potential line boundary.) */
3061 /* Two barewords in a row may indicate method call. */
3063 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
3066 /* If not a declared subroutine, it's an indirect object. */
3067 /* (But it's an indir obj regardless for sort.) */
3069 if ((PL_last_lop_op == OP_SORT ||
3070 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3071 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3072 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3077 /* If followed by a paren, it's certainly a subroutine. */
3079 PL_expect = XOPERATOR;
3083 if (gv && GvCVu(gv)) {
3084 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3085 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3090 PL_nextval[PL_nexttoke].opval = yylval.opval;
3091 PL_expect = XOPERATOR;
3097 /* If followed by var or block, call it a method (unless sub) */
3099 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3100 PL_last_lop = PL_oldbufptr;
3101 PL_last_lop_op = OP_METHOD;
3105 /* If followed by a bareword, see if it looks like indir obj. */
3107 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3110 /* Not a method, so call it a subroutine (if defined) */
3112 if (gv && GvCVu(gv)) {
3114 if (lastchar == '-')
3115 warn("Ambiguous use of -%s resolved as -&%s()",
3116 PL_tokenbuf, PL_tokenbuf);
3117 PL_last_lop = PL_oldbufptr;
3118 PL_last_lop_op = OP_ENTERSUB;
3119 /* Check for a constant sub */
3121 if ((sv = cv_const_sv(cv))) {
3123 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3124 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3125 yylval.opval->op_private = 0;
3129 /* Resolve to GV now. */
3130 op_free(yylval.opval);
3131 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3132 /* Is there a prototype? */
3135 PL_last_proto = SvPV((SV*)cv, len);
3138 if (strEQ(PL_last_proto, "$"))
3140 if (*PL_last_proto == '&' && *s == '{') {
3141 sv_setpv(PL_subname,"__ANON__");
3145 PL_last_proto = NULL;
3146 PL_nextval[PL_nexttoke].opval = yylval.opval;
3152 if (PL_hints & HINT_STRICT_SUBS &&
3155 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3156 PL_last_lop_op != OP_ACCEPT &&
3157 PL_last_lop_op != OP_PIPE_OP &&
3158 PL_last_lop_op != OP_SOCKPAIR)
3161 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3166 /* Call it a bare word */
3169 if (ckWARN(WARN_RESERVED)) {
3170 if (lastchar != '-') {
3171 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3173 warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
3178 if (lastchar && strchr("*%&", lastchar)) {
3179 warn("Operator or semicolon missing before %c%s",
3180 lastchar, PL_tokenbuf);
3181 warn("Ambiguous use of %c resolved as operator %c",
3182 lastchar, lastchar);
3188 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3189 newSVsv(GvSV(PL_curcop->cop_filegv)));
3193 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3194 newSVpvf("%ld", (long)PL_curcop->cop_line));
3197 case KEY___PACKAGE__:
3198 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3200 ? newSVsv(PL_curstname)
3209 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3210 char *pname = "main";
3211 if (PL_tokenbuf[2] == 'D')
3212 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3213 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3216 GvIOp(gv) = newIO();
3217 IoIFP(GvIOp(gv)) = PL_rsfp;
3218 #if defined(HAS_FCNTL) && defined(F_SETFD)
3220 int fd = PerlIO_fileno(PL_rsfp);
3221 fcntl(fd,F_SETFD,fd >= 3);
3224 /* Mark this internal pseudo-handle as clean */
3225 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3227 IoTYPE(GvIOp(gv)) = '|';
3228 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3229 IoTYPE(GvIOp(gv)) = '-';
3231 IoTYPE(GvIOp(gv)) = '<';
3242 if (PL_expect == XSTATE) {
3249 if (*s == ':' && s[1] == ':') {
3252 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3253 tmp = keyword(PL_tokenbuf, len);
3267 LOP(OP_ACCEPT,XTERM);
3273 LOP(OP_ATAN2,XTERM);
3282 LOP(OP_BLESS,XTERM);
3291 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3308 if (!PL_cryptseen++)
3311 LOP(OP_CRYPT,XTERM);
3314 if (ckWARN(WARN_OCTAL)) {
3315 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3316 if (*d != '0' && isDIGIT(*d))
3317 yywarn("chmod: mode argument is missing initial 0");
3319 LOP(OP_CHMOD,XTERM);
3322 LOP(OP_CHOWN,XTERM);
3325 LOP(OP_CONNECT,XTERM);
3341 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3345 PL_hints |= HINT_BLOCK_SCOPE;
3355 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3356 LOP(OP_DBMOPEN,XTERM);
3362 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3369 yylval.ival = PL_curcop->cop_line;
3383 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3384 UNIBRACK(OP_ENTEREVAL);
3399 case KEY_endhostent:
3405 case KEY_endservent:
3408 case KEY_endprotoent:
3419 yylval.ival = PL_curcop->cop_line;
3421 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3423 if ((PL_bufend - p) >= 3 &&
3424 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3428 croak("Missing $ on loop variable");
3433 LOP(OP_FORMLINE,XTERM);
3439 LOP(OP_FCNTL,XTERM);
3445 LOP(OP_FLOCK,XTERM);
3454 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3457 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3472 case KEY_getpriority:
3473 LOP(OP_GETPRIORITY,XTERM);
3475 case KEY_getprotobyname:
3478 case KEY_getprotobynumber:
3479 LOP(OP_GPBYNUMBER,XTERM);
3481 case KEY_getprotoent:
3493 case KEY_getpeername:
3494 UNI(OP_GETPEERNAME);
3496 case KEY_gethostbyname:
3499 case KEY_gethostbyaddr:
3500 LOP(OP_GHBYADDR,XTERM);
3502 case KEY_gethostent:
3505 case KEY_getnetbyname:
3508 case KEY_getnetbyaddr:
3509 LOP(OP_GNBYADDR,XTERM);
3514 case KEY_getservbyname:
3515 LOP(OP_GSBYNAME,XTERM);
3517 case KEY_getservbyport:
3518 LOP(OP_GSBYPORT,XTERM);
3520 case KEY_getservent:
3523 case KEY_getsockname:
3524 UNI(OP_GETSOCKNAME);
3526 case KEY_getsockopt:
3527 LOP(OP_GSOCKOPT,XTERM);
3549 yylval.ival = PL_curcop->cop_line;
3553 LOP(OP_INDEX,XTERM);
3559 LOP(OP_IOCTL,XTERM);
3571 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3602 LOP(OP_LISTEN,XTERM);
3611 s = scan_pat(s,OP_MATCH);
3612 TERM(sublex_start());
3615 LOP(OP_MAPSTART,XREF);
3618 LOP(OP_MKDIR,XTERM);
3621 LOP(OP_MSGCTL,XTERM);
3624 LOP(OP_MSGGET,XTERM);
3627 LOP(OP_MSGRCV,XTERM);
3630 LOP(OP_MSGSND,XTERM);
3635 if (isIDFIRST(*s)) {
3636 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3637 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3638 if (!PL_in_my_stash) {
3641 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3648 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3655 if (PL_expect != XSTATE)
3656 yyerror("\"no\" not allowed in expression");
3657 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3658 s = force_version(s);
3667 if (isIDFIRST(*s)) {
3669 for (d = s; isALNUM(*d); d++) ;
3671 if (strchr("|&*+-=!?:.", *t))
3672 warn("Precedence problem: open %.*s should be open(%.*s)",
3678 yylval.ival = OP_OR;
3688 LOP(OP_OPEN_DIR,XTERM);
3691 checkcomma(s,PL_tokenbuf,"filehandle");
3695 checkcomma(s,PL_tokenbuf,"filehandle");
3714 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3718 LOP(OP_PIPE_OP,XTERM);
3723 missingterm((char*)0);
3724 yylval.ival = OP_CONST;
3725 TERM(sublex_start());
3733 missingterm((char*)0);
3734 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3735 d = SvPV_force(PL_lex_stuff, len);
3736 for (; len; --len, ++d) {
3739 "Possible attempt to separate words with commas");
3744 "Possible attempt to put comments in qw() list");
3750 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3751 PL_lex_stuff = Nullsv;
3754 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3757 yylval.ival = OP_SPLIT;
3761 PL_last_lop = PL_oldbufptr;
3762 PL_last_lop_op = OP_SPLIT;
3768 missingterm((char*)0);
3769 yylval.ival = OP_STRINGIFY;
3770 if (SvIVX(PL_lex_stuff) == '\'')
3771 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3772 TERM(sublex_start());
3775 s = scan_pat(s,OP_QR);
3776 TERM(sublex_start());
3781 missingterm((char*)0);
3782 yylval.ival = OP_BACKTICK;
3784 TERM(sublex_start());
3790 *PL_tokenbuf = '\0';
3791 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3792 if (isIDFIRST(*PL_tokenbuf))
3793 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3795 yyerror("<> should be quotes");
3802 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3806 LOP(OP_RENAME,XTERM);
3815 LOP(OP_RINDEX,XTERM);
3838 LOP(OP_REVERSE,XTERM);
3849 TERM(sublex_start());
3851 TOKEN(1); /* force error */
3860 LOP(OP_SELECT,XTERM);
3866 LOP(OP_SEMCTL,XTERM);
3869 LOP(OP_SEMGET,XTERM);
3872 LOP(OP_SEMOP,XTERM);
3878 LOP(OP_SETPGRP,XTERM);
3880 case KEY_setpriority:
3881 LOP(OP_SETPRIORITY,XTERM);
3883 case KEY_sethostent:
3889 case KEY_setservent:
3892 case KEY_setprotoent:
3902 LOP(OP_SEEKDIR,XTERM);
3904 case KEY_setsockopt:
3905 LOP(OP_SSOCKOPT,XTERM);
3911 LOP(OP_SHMCTL,XTERM);
3914 LOP(OP_SHMGET,XTERM);
3917 LOP(OP_SHMREAD,XTERM);
3920 LOP(OP_SHMWRITE,XTERM);
3923 LOP(OP_SHUTDOWN,XTERM);
3932 LOP(OP_SOCKET,XTERM);
3934 case KEY_socketpair:
3935 LOP(OP_SOCKPAIR,XTERM);
3938 checkcomma(s,PL_tokenbuf,"subroutine name");
3940 if (*s == ';' || *s == ')') /* probably a close */
3941 croak("sort is now a reserved word");
3943 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3947 LOP(OP_SPLIT,XTERM);
3950 LOP(OP_SPRINTF,XTERM);
3953 LOP(OP_SPLICE,XTERM);
3969 LOP(OP_SUBSTR,XTERM);
3976 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3977 char tmpbuf[sizeof PL_tokenbuf];
3979 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3980 if (strchr(tmpbuf, ':'))
3981 sv_setpv(PL_subname, tmpbuf);
3983 sv_setsv(PL_subname,PL_curstname);
3984 sv_catpvn(PL_subname,"::",2);
3985 sv_catpvn(PL_subname,tmpbuf,len);
3987 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3991 PL_expect = XTERMBLOCK;
3992 sv_setpv(PL_subname,"?");
3995 if (tmp == KEY_format) {
3998 PL_lex_formbrack = PL_lex_brackets + 1;
4002 /* Look for a prototype */
4009 SvREFCNT_dec(PL_lex_stuff);
4010 PL_lex_stuff = Nullsv;
4011 croak("Prototype not terminated");
4014 d = SvPVX(PL_lex_stuff);
4016 for (p = d; *p; ++p) {
4021 SvCUR(PL_lex_stuff) = tmp;
4024 PL_nextval[1] = PL_nextval[0];
4025 PL_nexttype[1] = PL_nexttype[0];
4026 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4027 PL_nexttype[0] = THING;
4028 if (PL_nexttoke == 1) {
4029 PL_lex_defer = PL_lex_state;
4030 PL_lex_expect = PL_expect;
4031 PL_lex_state = LEX_KNOWNEXT;
4033 PL_lex_stuff = Nullsv;
4036 if (*SvPV(PL_subname,PL_na) == '?') {
4037 sv_setpv(PL_subname,"__ANON__");
4044 LOP(OP_SYSTEM,XREF);
4047 LOP(OP_SYMLINK,XTERM);
4050 LOP(OP_SYSCALL,XTERM);
4053 LOP(OP_SYSOPEN,XTERM);
4056 LOP(OP_SYSSEEK,XTERM);
4059 LOP(OP_SYSREAD,XTERM);
4062 LOP(OP_SYSWRITE,XTERM);
4066 TERM(sublex_start());
4087 LOP(OP_TRUNCATE,XTERM);
4099 yylval.ival = PL_curcop->cop_line;
4103 yylval.ival = PL_curcop->cop_line;
4107 LOP(OP_UNLINK,XTERM);
4113 LOP(OP_UNPACK,XTERM);
4116 LOP(OP_UTIME,XTERM);
4119 if (ckWARN(WARN_OCTAL)) {
4120 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4121 if (*d != '0' && isDIGIT(*d))
4122 yywarn("umask: argument is missing initial 0");
4127 LOP(OP_UNSHIFT,XTERM);
4130 if (PL_expect != XSTATE)
4131 yyerror("\"use\" not allowed in expression");
4134 s = force_version(s);
4135 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4136 PL_nextval[PL_nexttoke].opval = Nullop;
4141 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4142 s = force_version(s);
4155 yylval.ival = PL_curcop->cop_line;
4159 PL_hints |= HINT_BLOCK_SCOPE;
4166 LOP(OP_WAITPID,XTERM);
4174 static char ctl_l[2];
4176 if (ctl_l[0] == '\0')
4177 ctl_l[0] = toCTRL('L');
4178 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4181 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4186 if (PL_expect == XOPERATOR)
4192 yylval.ival = OP_XOR;
4197 TERM(sublex_start());
4203 keyword(register char *d, I32 len)
4208 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4209 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4210 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4211 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4212 if (strEQ(d,"__END__")) return KEY___END__;
4216 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4221 if (strEQ(d,"and")) return -KEY_and;
4222 if (strEQ(d,"abs")) return -KEY_abs;
4225 if (strEQ(d,"alarm")) return -KEY_alarm;
4226 if (strEQ(d,"atan2")) return -KEY_atan2;
4229 if (strEQ(d,"accept")) return -KEY_accept;
4234 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4237 if (strEQ(d,"bless")) return -KEY_bless;
4238 if (strEQ(d,"bind")) return -KEY_bind;
4239 if (strEQ(d,"binmode")) return -KEY_binmode;
4242 if (strEQ(d,"CORE")) return -KEY_CORE;
4247 if (strEQ(d,"cmp")) return -KEY_cmp;
4248 if (strEQ(d,"chr")) return -KEY_chr;
4249 if (strEQ(d,"cos")) return -KEY_cos;
4252 if (strEQ(d,"chop")) return KEY_chop;
4255 if (strEQ(d,"close")) return -KEY_close;
4256 if (strEQ(d,"chdir")) return -KEY_chdir;
4257 if (strEQ(d,"chomp")) return KEY_chomp;
4258 if (strEQ(d,"chmod")) return -KEY_chmod;
4259 if (strEQ(d,"chown")) return -KEY_chown;
4260 if (strEQ(d,"crypt")) return -KEY_crypt;
4263 if (strEQ(d,"chroot")) return -KEY_chroot;
4264 if (strEQ(d,"caller")) return -KEY_caller;
4267 if (strEQ(d,"connect")) return -KEY_connect;
4270 if (strEQ(d,"closedir")) return -KEY_closedir;
4271 if (strEQ(d,"continue")) return -KEY_continue;
4276 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4281 if (strEQ(d,"do")) return KEY_do;
4284 if (strEQ(d,"die")) return -KEY_die;
4287 if (strEQ(d,"dump")) return -KEY_dump;
4290 if (strEQ(d,"delete")) return KEY_delete;
4293 if (strEQ(d,"defined")) return KEY_defined;
4294 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4297 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4302 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4303 if (strEQ(d,"END")) return KEY_END;
4308 if (strEQ(d,"eq")) return -KEY_eq;
4311 if (strEQ(d,"eof")) return -KEY_eof;
4312 if (strEQ(d,"exp")) return -KEY_exp;
4315 if (strEQ(d,"else")) return KEY_else;
4316 if (strEQ(d,"exit")) return -KEY_exit;
4317 if (strEQ(d,"eval")) return KEY_eval;
4318 if (strEQ(d,"exec")) return -KEY_exec;
4319 if (strEQ(d,"each")) return KEY_each;
4322 if (strEQ(d,"elsif")) return KEY_elsif;
4325 if (strEQ(d,"exists")) return KEY_exists;
4326 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4329 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4330 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4333 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4336 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4337 if (strEQ(d,"endservent")) return -KEY_endservent;
4340 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4347 if (strEQ(d,"for")) return KEY_for;
4350 if (strEQ(d,"fork")) return -KEY_fork;
4353 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4354 if (strEQ(d,"flock")) return -KEY_flock;
4357 if (strEQ(d,"format")) return KEY_format;
4358 if (strEQ(d,"fileno")) return -KEY_fileno;
4361 if (strEQ(d,"foreach")) return KEY_foreach;
4364 if (strEQ(d,"formline")) return -KEY_formline;
4370 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4371 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4375 if (strnEQ(d,"get",3)) {
4380 if (strEQ(d,"ppid")) return -KEY_getppid;
4381 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4384 if (strEQ(d,"pwent")) return -KEY_getpwent;
4385 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4386 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4389 if (strEQ(d,"peername")) return -KEY_getpeername;
4390 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4391 if (strEQ(d,"priority")) return -KEY_getpriority;
4394 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4397 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4401 else if (*d == 'h') {
4402 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4403 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4404 if (strEQ(d,"hostent")) return -KEY_gethostent;
4406 else if (*d == 'n') {
4407 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4408 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4409 if (strEQ(d,"netent")) return -KEY_getnetent;
4411 else if (*d == 's') {
4412 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4413 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4414 if (strEQ(d,"servent")) return -KEY_getservent;
4415 if (strEQ(d,"sockname")) return -KEY_getsockname;
4416 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4418 else if (*d == 'g') {
4419 if (strEQ(d,"grent")) return -KEY_getgrent;
4420 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4421 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4423 else if (*d == 'l') {
4424 if (strEQ(d,"login")) return -KEY_getlogin;
4426 else if (strEQ(d,"c")) return -KEY_getc;
4431 if (strEQ(d,"gt")) return -KEY_gt;
4432 if (strEQ(d,"ge")) return -KEY_ge;
4435 if (strEQ(d,"grep")) return KEY_grep;
4436 if (strEQ(d,"goto")) return KEY_goto;
4437 if (strEQ(d,"glob")) return KEY_glob;
4440 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4445 if (strEQ(d,"hex")) return -KEY_hex;
4448 if (strEQ(d,"INIT")) return KEY_INIT;
4453 if (strEQ(d,"if")) return KEY_if;
4456 if (strEQ(d,"int")) return -KEY_int;
4459 if (strEQ(d,"index")) return -KEY_index;
4460 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4465 if (strEQ(d,"join")) return -KEY_join;
4469 if (strEQ(d,"keys")) return KEY_keys;
4470 if (strEQ(d,"kill")) return -KEY_kill;
4475 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4476 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4482 if (strEQ(d,"lt")) return -KEY_lt;
4483 if (strEQ(d,"le")) return -KEY_le;
4484 if (strEQ(d,"lc")) return -KEY_lc;
4487 if (strEQ(d,"log")) return -KEY_log;
4490 if (strEQ(d,"last")) return KEY_last;
4491 if (strEQ(d,"link")) return -KEY_link;
4492 if (strEQ(d,"lock")) return -KEY_lock;
4495 if (strEQ(d,"local")) return KEY_local;
4496 if (strEQ(d,"lstat")) return -KEY_lstat;
4499 if (strEQ(d,"length")) return -KEY_length;
4500 if (strEQ(d,"listen")) return -KEY_listen;
4503 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4506 if (strEQ(d,"localtime")) return -KEY_localtime;
4512 case 1: return KEY_m;
4514 if (strEQ(d,"my")) return KEY_my;
4517 if (strEQ(d,"map")) return KEY_map;
4520 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4523 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4524 if (strEQ(d,"msgget")) return -KEY_msgget;
4525 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4526 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4531 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4534 if (strEQ(d,"next")) return KEY_next;
4535 if (strEQ(d,"ne")) return -KEY_ne;
4536 if (strEQ(d,"not")) return -KEY_not;
4537 if (strEQ(d,"no")) return KEY_no;
4542 if (strEQ(d,"or")) return -KEY_or;
4545 if (strEQ(d,"ord")) return -KEY_ord;
4546 if (strEQ(d,"oct")) return -KEY_oct;
4547 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4551 if (strEQ(d,"open")) return -KEY_open;
4554 if (strEQ(d,"opendir")) return -KEY_opendir;
4561 if (strEQ(d,"pop")) return KEY_pop;
4562 if (strEQ(d,"pos")) return KEY_pos;
4565 if (strEQ(d,"push")) return KEY_push;
4566 if (strEQ(d,"pack")) return -KEY_pack;
4567 if (strEQ(d,"pipe")) return -KEY_pipe;
4570 if (strEQ(d,"print")) return KEY_print;
4573 if (strEQ(d,"printf")) return KEY_printf;
4576 if (strEQ(d,"package")) return KEY_package;
4579 if (strEQ(d,"prototype")) return KEY_prototype;
4584 if (strEQ(d,"q")) return KEY_q;
4585 if (strEQ(d,"qr")) return KEY_qr;
4586 if (strEQ(d,"qq")) return KEY_qq;
4587 if (strEQ(d,"qw")) return KEY_qw;
4588 if (strEQ(d,"qx")) return KEY_qx;
4590 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4595 if (strEQ(d,"ref")) return -KEY_ref;
4598 if (strEQ(d,"read")) return -KEY_read;
4599 if (strEQ(d,"rand")) return -KEY_rand;
4600 if (strEQ(d,"recv")) return -KEY_recv;
4601 if (strEQ(d,"redo")) return KEY_redo;
4604 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4605 if (strEQ(d,"reset")) return -KEY_reset;
4608 if (strEQ(d,"return")) return KEY_return;
4609 if (strEQ(d,"rename")) return -KEY_rename;
4610 if (strEQ(d,"rindex")) return -KEY_rindex;
4613 if (strEQ(d,"require")) return -KEY_require;
4614 if (strEQ(d,"reverse")) return -KEY_reverse;
4615 if (strEQ(d,"readdir")) return -KEY_readdir;
4618 if (strEQ(d,"readlink")) return -KEY_readlink;
4619 if (strEQ(d,"readline")) return -KEY_readline;
4620 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4623 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4629 case 0: return KEY_s;
4631 if (strEQ(d,"scalar")) return KEY_scalar;
4636 if (strEQ(d,"seek")) return -KEY_seek;
4637 if (strEQ(d,"send")) return -KEY_send;
4640 if (strEQ(d,"semop")) return -KEY_semop;
4643 if (strEQ(d,"select")) return -KEY_select;
4644 if (strEQ(d,"semctl")) return -KEY_semctl;
4645 if (strEQ(d,"semget")) return -KEY_semget;
4648 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4649 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4652 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4653 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4656 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4659 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4660 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4661 if (strEQ(d,"setservent")) return -KEY_setservent;
4664 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4665 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4672 if (strEQ(d,"shift")) return KEY_shift;
4675 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4676 if (strEQ(d,"shmget")) return -KEY_shmget;
4679 if (strEQ(d,"shmread")) return -KEY_shmread;
4682 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4683 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4688 if (strEQ(d,"sin")) return -KEY_sin;
4691 if (strEQ(d,"sleep")) return -KEY_sleep;
4694 if (strEQ(d,"sort")) return KEY_sort;
4695 if (strEQ(d,"socket")) return -KEY_socket;
4696 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4699 if (strEQ(d,"split")) return KEY_split;
4700 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4701 if (strEQ(d,"splice")) return KEY_splice;
4704 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4707 if (strEQ(d,"srand")) return -KEY_srand;
4710 if (strEQ(d,"stat")) return -KEY_stat;
4711 if (strEQ(d,"study")) return KEY_study;
4714 if (strEQ(d,"substr")) return -KEY_substr;
4715 if (strEQ(d,"sub")) return KEY_sub;
4720 if (strEQ(d,"system")) return -KEY_system;
4723 if (strEQ(d,"symlink")) return -KEY_symlink;
4724 if (strEQ(d,"syscall")) return -KEY_syscall;
4725 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4726 if (strEQ(d,"sysread")) return -KEY_sysread;
4727 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4730 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4739 if (strEQ(d,"tr")) return KEY_tr;
4742 if (strEQ(d,"tie")) return KEY_tie;
4745 if (strEQ(d,"tell")) return -KEY_tell;
4746 if (strEQ(d,"tied")) return KEY_tied;
4747 if (strEQ(d,"time")) return -KEY_time;
4750 if (strEQ(d,"times")) return -KEY_times;
4753 if (strEQ(d,"telldir")) return -KEY_telldir;
4756 if (strEQ(d,"truncate")) return -KEY_truncate;
4763 if (strEQ(d,"uc")) return -KEY_uc;
4766 if (strEQ(d,"use")) return KEY_use;
4769 if (strEQ(d,"undef")) return KEY_undef;
4770 if (strEQ(d,"until")) return KEY_until;
4771 if (strEQ(d,"untie")) return KEY_untie;
4772 if (strEQ(d,"utime")) return -KEY_utime;
4773 if (strEQ(d,"umask")) return -KEY_umask;
4776 if (strEQ(d,"unless")) return KEY_unless;
4777 if (strEQ(d,"unpack")) return -KEY_unpack;
4778 if (strEQ(d,"unlink")) return -KEY_unlink;
4781 if (strEQ(d,"unshift")) return KEY_unshift;
4782 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4787 if (strEQ(d,"values")) return -KEY_values;
4788 if (strEQ(d,"vec")) return -KEY_vec;
4793 if (strEQ(d,"warn")) return -KEY_warn;
4794 if (strEQ(d,"wait")) return -KEY_wait;
4797 if (strEQ(d,"while")) return KEY_while;
4798 if (strEQ(d,"write")) return -KEY_write;
4801 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4804 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4809 if (len == 1) return -KEY_x;
4810 if (strEQ(d,"xor")) return -KEY_xor;
4813 if (len == 1) return KEY_y;
4822 checkcomma(register char *s, char *name, char *what)
4826 if (ckWARN(WARN_SYNTAX) && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4828 for (w = s+2; *w && level; w++) {
4835 for (; *w && isSPACE(*w); w++) ;
4836 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4837 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4839 while (s < PL_bufend && isSPACE(*s))
4843 while (s < PL_bufend && isSPACE(*s))
4845 if (isIDFIRST(*s)) {
4849 while (s < PL_bufend && isSPACE(*s))
4854 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4858 croak("No comma allowed after %s", what);
4864 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4867 HV *table = GvHV(PL_hintgv); /* ^H */
4870 bool oldcatch = CATCH_GET;
4876 yyerror("%^H is not defined");
4879 cvp = hv_fetch(table, key, strlen(key), FALSE);
4880 if (!cvp || !SvOK(*cvp)) {
4881 sprintf(buf,"$^H{%s} is not defined", key);
4885 sv_2mortal(sv); /* Parent created it permanently */
4888 pv = sv_2mortal(newSVpv(s, len));
4890 typesv = sv_2mortal(newSVpv(type, 0));
4892 typesv = &PL_sv_undef;
4894 Zero(&myop, 1, BINOP);
4895 myop.op_last = (OP *) &myop;
4896 myop.op_next = Nullop;
4897 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4899 PUSHSTACKi(PERLSI_OVERLOAD);
4902 PL_op = (OP *) &myop;
4903 if (PERLDB_SUB && PL_curstash != PL_debstash)
4904 PL_op->op_private |= OPpENTERSUB_DB;
4915 if (PL_op = pp_entersub(ARGS))
4922 CATCH_SET(oldcatch);
4926 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4929 return SvREFCNT_inc(res);
4933 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4935 register char *d = dest;
4936 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4939 croak(ident_too_long);
4942 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4947 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4951 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8(s)) {
4952 char *t = s + UTF8SKIP(s);
4953 while (*t & 0x80 && is_utf8_mark(t))
4955 if (d + (t - s) > e)
4956 croak(ident_too_long);
4957 Copy(s, d, t - s, char);
4970 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4977 if (PL_lex_brackets == 0)
4978 PL_lex_fakebrack = 0;
4982 e = d + destlen - 3; /* two-character token, ending NUL */
4984 while (isDIGIT(*s)) {
4986 croak(ident_too_long);
4993 croak(ident_too_long);
4996 else if (*s == '\'' && isIDFIRST(s[1])) {
5001 else if (*s == ':' && s[1] == ':') {
5005 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8(s)) {
5006 char *t = s + UTF8SKIP(s);
5007 while (*t & 0x80 && is_utf8_mark(t))
5009 if (d + (t - s) > e)
5010 croak(ident_too_long);
5011 Copy(s, d, t - s, char);
5022 if (PL_lex_state != LEX_NORMAL)
5023 PL_lex_state = LEX_INTERPENDMAYBE;
5026 if (*s == '$' && s[1] &&
5027 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5029 if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
5030 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
5043 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5048 if (isSPACE(s[-1])) {
5051 if (ch != ' ' && ch != '\t') {
5057 if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8(d))) {
5061 while (e < send && (isALNUM(*e) || ((*e & 0xc0) == 0x80 && isALNUM_utf8((U8*)e)) || *e == ':')) {
5063 while (e < send && *e & 0x80 && is_utf8_mark(e))
5066 Copy(s, d, e - s, char);
5071 while (isALNUM(*s) || *s == ':')
5075 while (s < send && (*s == ' ' || *s == '\t')) s++;
5076 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5077 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5078 char *brack = *s == '[' ? "[...]" : "{...}";
5079 warner(WARN_AMBIGUOUS,
5080 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5081 funny, dest, brack, funny, dest, brack);
5083 PL_lex_fakebrack = PL_lex_brackets+1;
5085 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5091 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5092 PL_lex_state = LEX_INTERPEND;
5095 if (ckWARN(WARN_AMBIGUOUS) && PL_lex_state == LEX_NORMAL &&
5096 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5097 warner(WARN_AMBIGUOUS,
5098 "Ambiguous use of %c{%s} resolved to %c%s",
5099 funny, dest, funny, dest);
5102 s = bracket; /* let the parser handle it */
5106 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5107 PL_lex_state = LEX_INTERPEND;
5111 void pmflag(U16 *pmfl, int ch)
5116 *pmfl |= PMf_GLOBAL;
5118 *pmfl |= PMf_CONTINUE;
5122 *pmfl |= PMf_MULTILINE;
5124 *pmfl |= PMf_SINGLELINE;
5126 *pmfl |= PMf_EXTENDED;
5130 scan_pat(char *start, I32 type)
5135 s = scan_str(start);
5138 SvREFCNT_dec(PL_lex_stuff);
5139 PL_lex_stuff = Nullsv;
5140 croak("Search pattern not terminated");
5143 pm = (PMOP*)newPMOP(type, 0);
5144 if (PL_multi_open == '?')
5145 pm->op_pmflags |= PMf_ONCE;
5147 while (*s && strchr("iomsx", *s))
5148 pmflag(&pm->op_pmflags,*s++);
5151 while (*s && strchr("iogcmsx", *s))
5152 pmflag(&pm->op_pmflags,*s++);
5154 pm->op_pmpermflags = pm->op_pmflags;
5156 PL_lex_op = (OP*)pm;
5157 yylval.ival = OP_MATCH;
5162 scan_subst(char *start)
5169 yylval.ival = OP_NULL;
5171 s = scan_str(start);
5175 SvREFCNT_dec(PL_lex_stuff);
5176 PL_lex_stuff = Nullsv;
5177 croak("Substitution pattern not terminated");
5180 if (s[-1] == PL_multi_open)
5183 first_start = PL_multi_start;
5187 SvREFCNT_dec(PL_lex_stuff);
5188 PL_lex_stuff = Nullsv;
5190 SvREFCNT_dec(PL_lex_repl);
5191 PL_lex_repl = Nullsv;
5192 croak("Substitution replacement not terminated");
5194 PL_multi_start = first_start; /* so whole substitution is taken together */
5196 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5202 else if (strchr("iogcmsx", *s))
5203 pmflag(&pm->op_pmflags,*s++);
5210 pm->op_pmflags |= PMf_EVAL;
5211 repl = newSVpv("",0);
5213 sv_catpv(repl, es ? "eval " : "do ");
5214 sv_catpvn(repl, "{ ", 2);
5215 sv_catsv(repl, PL_lex_repl);
5216 sv_catpvn(repl, " };", 2);
5217 SvCOMPILED_on(repl);
5218 SvREFCNT_dec(PL_lex_repl);
5222 pm->op_pmpermflags = pm->op_pmflags;
5223 PL_lex_op = (OP*)pm;
5224 yylval.ival = OP_SUBST;
5229 scan_trans(char *start)
5240 yylval.ival = OP_NULL;
5242 s = scan_str(start);
5245 SvREFCNT_dec(PL_lex_stuff);
5246 PL_lex_stuff = Nullsv;
5247 croak("Transliteration pattern not terminated");
5249 if (s[-1] == PL_multi_open)
5255 SvREFCNT_dec(PL_lex_stuff);
5256 PL_lex_stuff = Nullsv;
5258 SvREFCNT_dec(PL_lex_repl);
5259 PL_lex_repl = Nullsv;
5260 croak("Transliteration replacement not terminated");
5264 o = newSVOP(OP_TRANS, 0, 0);
5265 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5268 New(803,tbl,256,short);
5269 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5273 complement = del = squash = 0;
5274 while (strchr("cdsCU", *s)) {
5276 complement = OPpTRANS_COMPLEMENT;
5278 del = OPpTRANS_DELETE;
5280 squash = OPpTRANS_SQUASH;
5285 utf8 &= ~OPpTRANS_FROM_UTF;
5287 utf8 |= OPpTRANS_FROM_UTF;
5291 utf8 &= ~OPpTRANS_TO_UTF;
5293 utf8 |= OPpTRANS_TO_UTF;
5296 croak("Too many /C and /U options");
5301 o->op_private = del|squash|complement|utf8;
5304 yylval.ival = OP_TRANS;
5309 scan_heredoc(register char *s)
5313 I32 op_type = OP_SCALAR;
5320 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5324 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5327 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5328 if (*peek && strchr("`'\"",*peek)) {
5331 s = delimcpy(d, e, s, PL_bufend, term, &len);
5342 deprecate("bare << to mean <<\"\"");
5343 for (; isALNUM(*s); s++) {
5348 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5349 croak("Delimiter for here document is too long");
5352 len = d - PL_tokenbuf;
5353 #ifndef PERL_STRICT_CR
5354 d = strchr(s, '\r');
5358 while (s < PL_bufend) {
5364 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5373 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5378 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5379 herewas = newSVpv(s,PL_bufend-s);
5381 s--, herewas = newSVpv(s,d-s);
5382 s += SvCUR(herewas);
5384 tmpstr = NEWSV(87,79);
5385 sv_upgrade(tmpstr, SVt_PVIV);
5390 else if (term == '`') {
5391 op_type = OP_BACKTICK;
5392 SvIVX(tmpstr) = '\\';
5396 PL_multi_start = PL_curcop->cop_line;
5397 PL_multi_open = PL_multi_close = '<';
5398 term = *PL_tokenbuf;
5401 while (s < PL_bufend &&
5402 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5404 PL_curcop->cop_line++;
5406 if (s >= PL_bufend) {
5407 PL_curcop->cop_line = PL_multi_start;
5408 missingterm(PL_tokenbuf);
5410 sv_setpvn(tmpstr,d+1,s-d);
5412 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5414 sv_catpvn(herewas,s,PL_bufend-s);
5415 sv_setsv(PL_linestr,herewas);
5416 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5417 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5420 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5421 while (s >= PL_bufend) { /* multiple line string? */
5423 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5424 PL_curcop->cop_line = PL_multi_start;
5425 missingterm(PL_tokenbuf);
5427 PL_curcop->cop_line++;
5428 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5429 #ifndef PERL_STRICT_CR
5430 if (PL_bufend - PL_linestart >= 2) {
5431 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5432 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5434 PL_bufend[-2] = '\n';
5436 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5438 else if (PL_bufend[-1] == '\r')
5439 PL_bufend[-1] = '\n';
5441 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5442 PL_bufend[-1] = '\n';
5444 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5445 SV *sv = NEWSV(88,0);
5447 sv_upgrade(sv, SVt_PVMG);
5448 sv_setsv(sv,PL_linestr);
5449 av_store(GvAV(PL_curcop->cop_filegv),
5450 (I32)PL_curcop->cop_line,sv);
5452 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5455 sv_catsv(PL_linestr,herewas);
5456 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5460 sv_catsv(tmpstr,PL_linestr);
5463 PL_multi_end = PL_curcop->cop_line;
5465 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5466 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5467 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5469 SvREFCNT_dec(herewas);
5470 PL_lex_stuff = tmpstr;
5471 yylval.ival = op_type;
5476 takes: current position in input buffer
5477 returns: new position in input buffer
5478 side-effects: yylval and lex_op are set.
5483 <FH> read from filehandle
5484 <pkg::FH> read from package qualified filehandle
5485 <pkg'FH> read from package qualified filehandle
5486 <$fh> read from filehandle in $fh
5492 scan_inputsymbol(char *start)
5494 register char *s = start; /* current position in buffer */
5499 d = PL_tokenbuf; /* start of temp holding space */
5500 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5501 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5503 /* die if we didn't have space for the contents of the <>,
5507 if (len >= sizeof PL_tokenbuf)
5508 croak("Excessively long <> operator");
5510 croak("Unterminated <> operator");
5515 Remember, only scalar variables are interpreted as filehandles by
5516 this code. Anything more complex (e.g., <$fh{$num}>) will be
5517 treated as a glob() call.
5518 This code makes use of the fact that except for the $ at the front,
5519 a scalar variable and a filehandle look the same.
5521 if (*d == '$' && d[1]) d++;
5523 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5524 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5527 /* If we've tried to read what we allow filehandles to look like, and
5528 there's still text left, then it must be a glob() and not a getline.
5529 Use scan_str to pull out the stuff between the <> and treat it
5530 as nothing more than a string.
5533 if (d - PL_tokenbuf != len) {
5534 yylval.ival = OP_GLOB;
5536 s = scan_str(start);
5538 croak("Glob not terminated");
5542 /* we're in a filehandle read situation */
5545 /* turn <> into <ARGV> */
5547 (void)strcpy(d,"ARGV");
5549 /* if <$fh>, create the ops to turn the variable into a
5555 /* try to find it in the pad for this block, otherwise find
5556 add symbol table ops
5558 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5559 OP *o = newOP(OP_PADSV, 0);
5561 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5564 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5565 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5566 newUNOP(OP_RV2GV, 0,
5567 newUNOP(OP_RV2SV, 0,
5568 newGVOP(OP_GV, 0, gv))));
5570 /* we created the ops in lex_op, so make yylval.ival a null op */
5571 yylval.ival = OP_NULL;
5574 /* If it's none of the above, it must be a literal filehandle
5575 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5577 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5578 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5579 yylval.ival = OP_NULL;
5588 takes: start position in buffer
5589 returns: position to continue reading from buffer
5590 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5591 updates the read buffer.
5593 This subroutine pulls a string out of the input. It is called for:
5594 q single quotes q(literal text)
5595 ' single quotes 'literal text'
5596 qq double quotes qq(interpolate $here please)
5597 " double quotes "interpolate $here please"
5598 qx backticks qx(/bin/ls -l)
5599 ` backticks `/bin/ls -l`
5600 qw quote words @EXPORT_OK = qw( func() $spam )
5601 m// regexp match m/this/
5602 s/// regexp substitute s/this/that/
5603 tr/// string transliterate tr/this/that/
5604 y/// string transliterate y/this/that/
5605 ($*@) sub prototypes sub foo ($)
5606 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5608 In most of these cases (all but <>, patterns and transliterate)
5609 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5610 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5611 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5614 It skips whitespace before the string starts, and treats the first
5615 character as the delimiter. If the delimiter is one of ([{< then
5616 the corresponding "close" character )]}> is used as the closing
5617 delimiter. It allows quoting of delimiters, and if the string has
5618 balanced delimiters ([{<>}]) it allows nesting.
5620 The lexer always reads these strings into lex_stuff, except in the
5621 case of the operators which take *two* arguments (s/// and tr///)
5622 when it checks to see if lex_stuff is full (presumably with the 1st
5623 arg to s or tr) and if so puts the string into lex_repl.
5628 scan_str(char *start)
5631 SV *sv; /* scalar value: string */
5632 char *tmps; /* temp string, used for delimiter matching */
5633 register char *s = start; /* current position in the buffer */
5634 register char term; /* terminating character */
5635 register char *to; /* current position in the sv's data */
5636 I32 brackets = 1; /* bracket nesting level */
5638 /* skip space before the delimiter */
5642 /* mark where we are, in case we need to report errors */
5645 /* after skipping whitespace, the next character is the terminator */
5647 /* mark where we are */
5648 PL_multi_start = PL_curcop->cop_line;
5649 PL_multi_open = term;
5651 /* find corresponding closing delimiter */
5652 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5654 PL_multi_close = term;
5656 /* create a new SV to hold the contents. 87 is leak category, I'm
5657 assuming. 79 is the SV's initial length. What a random number. */
5659 sv_upgrade(sv, SVt_PVIV);
5661 (void)SvPOK_only(sv); /* validate pointer */
5663 /* move past delimiter and try to read a complete string */
5666 /* extend sv if need be */
5667 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5668 /* set 'to' to the next character in the sv's string */
5669 to = SvPVX(sv)+SvCUR(sv);
5671 /* if open delimiter is the close delimiter read unbridle */
5672 if (PL_multi_open == PL_multi_close) {
5673 for (; s < PL_bufend; s++,to++) {
5674 /* embedded newlines increment the current line number */
5675 if (*s == '\n' && !PL_rsfp)
5676 PL_curcop->cop_line++;
5677 /* handle quoted delimiters */
5678 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5681 /* any other quotes are simply copied straight through */
5685 /* terminate when run out of buffer (the for() condition), or
5686 have found the terminator */
5687 else if (*s == term)
5693 /* if the terminator isn't the same as the start character (e.g.,
5694 matched brackets), we have to allow more in the quoting, and
5695 be prepared for nested brackets.
5698 /* read until we run out of string, or we find the terminator */
5699 for (; s < PL_bufend; s++,to++) {
5700 /* embedded newlines increment the line count */
5701 if (*s == '\n' && !PL_rsfp)
5702 PL_curcop->cop_line++;
5703 /* backslashes can escape the open or closing characters */
5704 if (*s == '\\' && s+1 < PL_bufend) {
5705 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5710 /* allow nested opens and closes */
5711 else if (*s == PL_multi_close && --brackets <= 0)
5713 else if (*s == PL_multi_open)
5718 /* terminate the copied string and update the sv's end-of-string */
5720 SvCUR_set(sv, to - SvPVX(sv));
5723 * this next chunk reads more into the buffer if we're not done yet
5726 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5728 #ifndef PERL_STRICT_CR
5729 if (to - SvPVX(sv) >= 2) {
5730 if ((to[-2] == '\r' && to[-1] == '\n') ||
5731 (to[-2] == '\n' && to[-1] == '\r'))
5735 SvCUR_set(sv, to - SvPVX(sv));
5737 else if (to[-1] == '\r')
5740 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5744 /* if we're out of file, or a read fails, bail and reset the current
5745 line marker so we can report where the unterminated string began
5748 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5750 PL_curcop->cop_line = PL_multi_start;
5753 /* we read a line, so increment our line counter */
5754 PL_curcop->cop_line++;
5756 /* update debugger info */
5757 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5758 SV *sv = NEWSV(88,0);
5760 sv_upgrade(sv, SVt_PVMG);
5761 sv_setsv(sv,PL_linestr);
5762 av_store(GvAV(PL_curcop->cop_filegv),
5763 (I32)PL_curcop->cop_line, sv);
5766 /* having changed the buffer, we must update PL_bufend */
5767 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5770 /* at this point, we have successfully read the delimited string */
5772 PL_multi_end = PL_curcop->cop_line;
5775 /* if we allocated too much space, give some back */
5776 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5777 SvLEN_set(sv, SvCUR(sv) + 1);
5778 Renew(SvPVX(sv), SvLEN(sv), char);
5781 /* decide whether this is the first or second quoted string we've read
5794 takes: pointer to position in buffer
5795 returns: pointer to new position in buffer
5796 side-effects: builds ops for the constant in yylval.op
5798 Read a number in any of the formats that Perl accepts:
5800 0(x[0-7A-F]+)|([0-7]+)
5801 [\d_]+(\.[\d_]*)?[Ee](\d+)
5803 Underbars (_) are allowed in decimal numbers. If -w is on,
5804 underbars before a decimal point must be at three digit intervals.
5806 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5809 If it reads a number without a decimal point or an exponent, it will
5810 try converting the number to an integer and see if it can do so
5811 without loss of precision.
5815 scan_num(char *start)
5817 register char *s = start; /* current position in buffer */
5818 register char *d; /* destination in temp buffer */
5819 register char *e; /* end of temp buffer */
5820 I32 tryiv; /* used to see if it can be an int */
5821 double value; /* number read, as a double */
5822 SV *sv; /* place to put the converted number */
5823 I32 floatit; /* boolean: int or float? */
5824 char *lastub = 0; /* position of last underbar */
5825 static char number_too_long[] = "Number too long";
5827 /* We use the first character to decide what type of number this is */
5831 croak("panic: scan_num");
5833 /* if it starts with a 0, it could be an octal number, a decimal in
5834 0.13 disguise, or a hexadecimal number.
5839 u holds the "number so far"
5840 shift the power of 2 of the base (hex == 4, octal == 3)
5841 overflowed was the number more than we can hold?
5843 Shift is used when we add a digit. It also serves as an "are
5844 we in octal or hex?" indicator to disallow hex characters when
5849 bool overflowed = FALSE;
5856 /* check for a decimal in disguise */
5857 else if (s[1] == '.')
5859 /* so it must be octal */
5864 /* read the rest of the octal number */
5866 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5870 /* if we don't mention it, we're done */
5879 /* 8 and 9 are not octal */
5882 yyerror("Illegal octal digit");
5886 case '0': case '1': case '2': case '3': case '4':
5887 case '5': case '6': case '7':
5888 b = *s++ & 15; /* ASCII digit -> value of digit */
5892 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5893 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5894 /* make sure they said 0x */
5899 /* Prepare to put the digit we have onto the end
5900 of the number so far. We check for overflows.
5904 n = u << shift; /* make room for the digit */
5905 if (!overflowed && (n >> shift) != u
5906 && !(PL_hints & HINT_NEW_BINARY)) {
5907 warn("Integer overflow in %s number",
5908 (shift == 4) ? "hex" : "octal");
5911 u = n | b; /* add the digit to the end */
5916 /* if we get here, we had success: make a scalar value from
5922 if ( PL_hints & HINT_NEW_BINARY)
5923 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5928 handle decimal numbers.
5929 we're also sent here when we read a 0 as the first digit
5931 case '1': case '2': case '3': case '4': case '5':
5932 case '6': case '7': case '8': case '9': case '.':
5935 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5938 /* read next group of digits and _ and copy into d */
5939 while (isDIGIT(*s) || *s == '_') {
5940 /* skip underscores, checking for misplaced ones
5944 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
5945 warner(WARN_SYNTAX, "Misplaced _ in number");
5949 /* check for end of fixed-length buffer */
5951 croak(number_too_long);
5952 /* if we're ok, copy the character */
5957 /* final misplaced underbar check */
5958 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
5959 warner(WARN_SYNTAX, "Misplaced _ in number");
5961 /* read a decimal portion if there is one. avoid
5962 3..5 being interpreted as the number 3. followed
5965 if (*s == '.' && s[1] != '.') {
5969 /* copy, ignoring underbars, until we run out of
5970 digits. Note: no misplaced underbar checks!
5972 for (; isDIGIT(*s) || *s == '_'; s++) {
5973 /* fixed length buffer check */
5975 croak(number_too_long);
5981 /* read exponent part, if present */
5982 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5986 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5987 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5989 /* allow positive or negative exponent */
5990 if (*s == '+' || *s == '-')
5993 /* read digits of exponent (no underbars :-) */
5994 while (isDIGIT(*s)) {
5996 croak(number_too_long);
6001 /* terminate the string */
6004 /* make an sv from the string */
6006 /* reset numeric locale in case we were earlier left in Swaziland */
6007 SET_NUMERIC_STANDARD();
6008 value = atof(PL_tokenbuf);
6011 See if we can make do with an integer value without loss of
6012 precision. We use I_V to cast to an int, because some
6013 compilers have issues. Then we try casting it back and see
6014 if it was the same. We only do this if we know we
6015 specifically read an integer.
6017 Note: if floatit is true, then we don't need to do the
6021 if (!floatit && (double)tryiv == value)
6022 sv_setiv(sv, tryiv);
6024 sv_setnv(sv, value);
6025 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6026 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6027 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6031 /* make the op for the constant and return */
6033 yylval.opval = newSVOP(OP_CONST, 0, sv);
6039 scan_formline(register char *s)
6044 SV *stuff = newSVpv("",0);
6045 bool needargs = FALSE;
6048 if (*s == '.' || *s == '}') {
6050 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
6054 if (PL_in_eval && !PL_rsfp) {
6055 eol = strchr(s,'\n');
6060 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6062 for (t = s; t < eol; t++) {
6063 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6065 goto enough; /* ~~ must be first line in formline */
6067 if (*t == '@' || *t == '^')
6070 sv_catpvn(stuff, s, eol-s);
6074 s = filter_gets(PL_linestr, PL_rsfp, 0);
6075 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6076 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6079 yyerror("Format not terminated");
6089 PL_lex_state = LEX_NORMAL;
6090 PL_nextval[PL_nexttoke].ival = 0;
6094 PL_lex_state = LEX_FORMLINE;
6095 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6097 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6101 SvREFCNT_dec(stuff);
6102 PL_lex_formbrack = 0;
6113 PL_cshlen = strlen(PL_cshname);
6118 start_subparse(I32 is_format, U32 flags)
6121 I32 oldsavestack_ix = PL_savestack_ix;
6122 CV* outsidecv = PL_compcv;
6126 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6128 save_I32(&PL_subline);
6129 save_item(PL_subname);
6131 SAVESPTR(PL_curpad);
6132 SAVESPTR(PL_comppad);
6133 SAVESPTR(PL_comppad_name);
6134 SAVESPTR(PL_compcv);
6135 SAVEI32(PL_comppad_name_fill);
6136 SAVEI32(PL_min_intro_pending);
6137 SAVEI32(PL_max_intro_pending);
6138 SAVEI32(PL_pad_reset_pending);
6140 PL_compcv = (CV*)NEWSV(1104,0);
6141 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6142 CvFLAGS(PL_compcv) |= flags;
6144 PL_comppad = newAV();
6145 av_push(PL_comppad, Nullsv);
6146 PL_curpad = AvARRAY(PL_comppad);
6147 PL_comppad_name = newAV();
6148 PL_comppad_name_fill = 0;
6149 PL_min_intro_pending = 0;
6151 PL_subline = PL_curcop->cop_line;
6153 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6154 PL_curpad[0] = (SV*)newAV();
6155 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6156 #endif /* USE_THREADS */
6158 comppadlist = newAV();
6159 AvREAL_off(comppadlist);
6160 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6161 av_store(comppadlist, 1, (SV*)PL_comppad);
6163 CvPADLIST(PL_compcv) = comppadlist;
6164 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6166 CvOWNER(PL_compcv) = 0;
6167 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6168 MUTEX_INIT(CvMUTEXP(PL_compcv));
6169 #endif /* USE_THREADS */
6171 return oldsavestack_ix;
6190 char *context = NULL;
6194 if (!yychar || (yychar == ';' && !PL_rsfp))
6196 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6197 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6198 while (isSPACE(*PL_oldoldbufptr))
6200 context = PL_oldoldbufptr;
6201 contlen = PL_bufptr - PL_oldoldbufptr;
6203 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6204 PL_oldbufptr != PL_bufptr) {
6205 while (isSPACE(*PL_oldbufptr))
6207 context = PL_oldbufptr;
6208 contlen = PL_bufptr - PL_oldbufptr;
6210 else if (yychar > 255)
6211 where = "next token ???";
6212 else if ((yychar & 127) == 127) {
6213 if (PL_lex_state == LEX_NORMAL ||
6214 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6215 where = "at end of line";
6216 else if (PL_lex_inpat)
6217 where = "within pattern";
6219 where = "within string";
6222 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6224 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6225 else if (isPRINT_LC(yychar))
6226 sv_catpvf(where_sv, "%c", yychar);
6228 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6229 where = SvPVX(where_sv);
6231 msg = sv_2mortal(newSVpv(s, 0));
6232 sv_catpvf(msg, " at %_ line %ld, ",
6233 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6235 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6237 sv_catpvf(msg, "%s\n", where);
6238 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6240 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6241 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6246 else if (PL_in_eval)
6247 sv_catsv(ERRSV, msg);
6249 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6250 if (++PL_error_count >= 10)
6251 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6253 PL_in_my_stash = Nullhv;