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);
216 warn("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 && PL_dowarn && 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]))
1009 warn("\\%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 (PL_dowarn && !utf)
1051 warn("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 (PL_dowarn && 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 (PL_dowarn && isALPHA(*s) && PL_bufptr == PL_linestart) {
2473 PL_curcop->cop_line--;
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 (PL_dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2507 warn("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] = '@';
2639 isSPACE(*t) || isALNUM(*t) || *t == '$';
2642 PL_bufptr = skipspace(PL_bufptr);
2643 while (t < PL_bufend && *t != ']')
2645 warn("Multidimensional syntax %.*s not supported",
2646 (t - PL_bufptr) + 1, PL_bufptr);
2650 else if (*s == '{') {
2651 PL_tokenbuf[0] = '%';
2652 if (PL_dowarn && strEQ(PL_tokenbuf+1, "SIG") &&
2653 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2655 char tmpbuf[sizeof PL_tokenbuf];
2657 for (t++; isSPACE(*t); t++) ;
2658 if (isIDFIRST(*t)) {
2659 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2660 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2661 warn("You need to quote \"%s\"", tmpbuf);
2667 PL_expect = XOPERATOR;
2668 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2669 bool islop = (PL_last_lop == PL_oldoldbufptr);
2670 if (!islop || PL_last_lop_op == OP_GREPSTART)
2671 PL_expect = XOPERATOR;
2672 else if (strchr("$@\"'`q", *s))
2673 PL_expect = XTERM; /* e.g. print $fh "foo" */
2674 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2675 PL_expect = XTERM; /* e.g. print $fh &sub */
2676 else if (isIDFIRST(*s)) {
2677 char tmpbuf[sizeof PL_tokenbuf];
2678 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2679 if (tmp = keyword(tmpbuf, len)) {
2680 /* binary operators exclude handle interpretations */
2692 PL_expect = XTERM; /* e.g. print $fh length() */
2697 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2698 if (gv && GvCVu(gv))
2699 PL_expect = XTERM; /* e.g. print $fh subr() */
2702 else if (isDIGIT(*s))
2703 PL_expect = XTERM; /* e.g. print $fh 3 */
2704 else if (*s == '.' && isDIGIT(s[1]))
2705 PL_expect = XTERM; /* e.g. print $fh .3 */
2706 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2707 PL_expect = XTERM; /* e.g. print $fh -1 */
2708 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2709 PL_expect = XTERM; /* print $fh <<"EOF" */
2711 PL_pending_ident = '$';
2715 if (PL_expect == XOPERATOR)
2717 PL_tokenbuf[0] = '@';
2718 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2719 if (!PL_tokenbuf[1]) {
2721 yyerror("Final @ should be \\@ or @name");
2724 if (PL_lex_state == LEX_NORMAL)
2726 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2728 PL_tokenbuf[0] = '%';
2730 /* Warn about @ where they meant $. */
2732 if (*s == '[' || *s == '{') {
2734 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2736 if (*t == '}' || *t == ']') {
2738 PL_bufptr = skipspace(PL_bufptr);
2739 warn("Scalar value %.*s better written as $%.*s",
2740 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2745 PL_pending_ident = '@';
2748 case '/': /* may either be division or pattern */
2749 case '?': /* may either be conditional or pattern */
2750 if (PL_expect != XOPERATOR) {
2751 /* Disable warning on "study /blah/" */
2752 if (PL_oldoldbufptr == PL_last_uni
2753 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2754 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2756 s = scan_pat(s,OP_MATCH);
2757 TERM(sublex_start());
2765 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack && s[1] == '\n' &&
2766 (s == PL_linestart || s[-1] == '\n') ) {
2767 PL_lex_formbrack = 0;
2771 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2777 yylval.ival = OPf_SPECIAL;
2783 if (PL_expect != XOPERATOR)
2788 case '0': case '1': case '2': case '3': case '4':
2789 case '5': case '6': case '7': case '8': case '9':
2791 if (PL_expect == XOPERATOR)
2797 if (PL_expect == XOPERATOR) {
2798 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2801 return ','; /* grandfather non-comma-format format */
2807 missingterm((char*)0);
2808 yylval.ival = OP_CONST;
2809 TERM(sublex_start());
2813 if (PL_expect == XOPERATOR) {
2814 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2817 return ','; /* grandfather non-comma-format format */
2823 missingterm((char*)0);
2824 yylval.ival = OP_CONST;
2825 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2826 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2827 yylval.ival = OP_STRINGIFY;
2831 TERM(sublex_start());
2835 if (PL_expect == XOPERATOR)
2836 no_op("Backticks",s);
2838 missingterm((char*)0);
2839 yylval.ival = OP_BACKTICK;
2841 TERM(sublex_start());
2845 if (PL_dowarn && PL_lex_inwhat && isDIGIT(*s))
2846 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2847 if (PL_expect == XOPERATOR)
2848 no_op("Backslash",s);
2852 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2891 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2893 /* Some keywords can be followed by any delimiter, including ':' */
2894 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2895 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2896 (PL_tokenbuf[0] == 'q' &&
2897 strchr("qwxr", PL_tokenbuf[1]))));
2899 /* x::* is just a word, unless x is "CORE" */
2900 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2904 while (d < PL_bufend && isSPACE(*d))
2905 d++; /* no comments skipped here, or s### is misparsed */
2907 /* Is this a label? */
2908 if (!tmp && PL_expect == XSTATE
2909 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2911 yylval.pval = savepv(PL_tokenbuf);
2916 /* Check for keywords */
2917 tmp = keyword(PL_tokenbuf, len);
2919 /* Is this a word before a => operator? */
2920 if (strnEQ(d,"=>",2)) {
2922 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2923 yylval.opval->op_private = OPpCONST_BARE;
2927 if (tmp < 0) { /* second-class keyword? */
2928 GV *ogv = Nullgv; /* override (winner) */
2929 GV *hgv = Nullgv; /* hidden (loser) */
2930 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2932 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
2935 if (GvIMPORTED_CV(gv))
2937 else if (! CvMETHOD(cv))
2941 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2942 (gv = *gvp) != (GV*)&PL_sv_undef &&
2943 GvCVu(gv) && GvIMPORTED_CV(gv))
2949 tmp = 0; /* overridden by import or by GLOBAL */
2952 && -tmp==KEY_lock /* XXX generalizable kludge */
2953 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
2955 tmp = 0; /* any sub overrides "weak" keyword */
2957 else { /* no override */
2961 if (PL_dowarn && hgv)
2962 warn("Ambiguous call resolved as CORE::%s(), %s",
2963 GvENAME(hgv), "qualify as such or use &");
2970 default: /* not a keyword */
2973 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
2975 /* Get the rest if it looks like a package qualifier */
2977 if (*s == '\'' || *s == ':' && s[1] == ':') {
2979 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
2982 croak("Bad name after %s%s", PL_tokenbuf,
2983 *s == '\'' ? "'" : "::");
2987 if (PL_expect == XOPERATOR) {
2988 if (PL_bufptr == PL_linestart) {
2989 PL_curcop->cop_line--;
2991 PL_curcop->cop_line++;
2994 no_op("Bareword",s);
2997 /* Look for a subroutine with this name in current package,
2998 unless name is "Foo::", in which case Foo is a bearword
2999 (and a package name). */
3002 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3004 if (PL_dowarn && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3005 warn("Bareword \"%s\" refers to nonexistent package",
3008 PL_tokenbuf[len] = '\0';
3015 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3018 /* if we saw a global override before, get the right name */
3021 sv = newSVpv("CORE::GLOBAL::",14);
3022 sv_catpv(sv,PL_tokenbuf);
3025 sv = newSVpv(PL_tokenbuf,0);
3027 /* Presume this is going to be a bareword of some sort. */
3030 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3031 yylval.opval->op_private = OPpCONST_BARE;
3033 /* And if "Foo::", then that's what it certainly is. */
3038 /* See if it's the indirect object for a list operator. */
3040 if (PL_oldoldbufptr &&
3041 PL_oldoldbufptr < PL_bufptr &&
3042 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3043 /* NO SKIPSPACE BEFORE HERE! */
3045 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3046 || (PL_last_lop_op == OP_ENTERSUB
3048 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3050 bool immediate_paren = *s == '(';
3052 /* (Now we can afford to cross potential line boundary.) */
3055 /* Two barewords in a row may indicate method call. */
3057 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
3060 /* If not a declared subroutine, it's an indirect object. */
3061 /* (But it's an indir obj regardless for sort.) */
3063 if ((PL_last_lop_op == OP_SORT ||
3064 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3065 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3066 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3071 /* If followed by a paren, it's certainly a subroutine. */
3073 PL_expect = XOPERATOR;
3077 if (gv && GvCVu(gv)) {
3078 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3079 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3084 PL_nextval[PL_nexttoke].opval = yylval.opval;
3085 PL_expect = XOPERATOR;
3091 /* If followed by var or block, call it a method (unless sub) */
3093 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3094 PL_last_lop = PL_oldbufptr;
3095 PL_last_lop_op = OP_METHOD;
3099 /* If followed by a bareword, see if it looks like indir obj. */
3101 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3104 /* Not a method, so call it a subroutine (if defined) */
3106 if (gv && GvCVu(gv)) {
3108 if (lastchar == '-')
3109 warn("Ambiguous use of -%s resolved as -&%s()",
3110 PL_tokenbuf, PL_tokenbuf);
3111 PL_last_lop = PL_oldbufptr;
3112 PL_last_lop_op = OP_ENTERSUB;
3113 /* Check for a constant sub */
3115 if ((sv = cv_const_sv(cv))) {
3117 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3118 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3119 yylval.opval->op_private = 0;
3123 /* Resolve to GV now. */
3124 op_free(yylval.opval);
3125 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3126 /* Is there a prototype? */
3129 PL_last_proto = SvPV((SV*)cv, len);
3132 if (strEQ(PL_last_proto, "$"))
3134 if (*PL_last_proto == '&' && *s == '{') {
3135 sv_setpv(PL_subname,"__ANON__");
3139 PL_last_proto = NULL;
3140 PL_nextval[PL_nexttoke].opval = yylval.opval;
3146 if (PL_hints & HINT_STRICT_SUBS &&
3149 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3150 PL_last_lop_op != OP_ACCEPT &&
3151 PL_last_lop_op != OP_PIPE_OP &&
3152 PL_last_lop_op != OP_SOCKPAIR)
3155 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3160 /* Call it a bare word */
3164 if (lastchar != '-') {
3165 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3167 warn(warn_reserved, PL_tokenbuf);
3172 if (lastchar && strchr("*%&", lastchar)) {
3173 warn("Operator or semicolon missing before %c%s",
3174 lastchar, PL_tokenbuf);
3175 warn("Ambiguous use of %c resolved as operator %c",
3176 lastchar, lastchar);
3182 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3183 newSVsv(GvSV(PL_curcop->cop_filegv)));
3187 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3188 newSVpvf("%ld", (long)PL_curcop->cop_line));
3191 case KEY___PACKAGE__:
3192 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3194 ? newSVsv(PL_curstname)
3203 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3204 char *pname = "main";
3205 if (PL_tokenbuf[2] == 'D')
3206 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3207 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3210 GvIOp(gv) = newIO();
3211 IoIFP(GvIOp(gv)) = PL_rsfp;
3212 #if defined(HAS_FCNTL) && defined(F_SETFD)
3214 int fd = PerlIO_fileno(PL_rsfp);
3215 fcntl(fd,F_SETFD,fd >= 3);
3218 /* Mark this internal pseudo-handle as clean */
3219 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3221 IoTYPE(GvIOp(gv)) = '|';
3222 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3223 IoTYPE(GvIOp(gv)) = '-';
3225 IoTYPE(GvIOp(gv)) = '<';
3236 if (PL_expect == XSTATE) {
3243 if (*s == ':' && s[1] == ':') {
3246 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3247 tmp = keyword(PL_tokenbuf, len);
3261 LOP(OP_ACCEPT,XTERM);
3267 LOP(OP_ATAN2,XTERM);
3276 LOP(OP_BLESS,XTERM);
3285 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3302 if (!PL_cryptseen++)
3305 LOP(OP_CRYPT,XTERM);
3309 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3310 if (*d != '0' && isDIGIT(*d))
3311 yywarn("chmod: mode argument is missing initial 0");
3313 LOP(OP_CHMOD,XTERM);
3316 LOP(OP_CHOWN,XTERM);
3319 LOP(OP_CONNECT,XTERM);
3335 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3339 PL_hints |= HINT_BLOCK_SCOPE;
3349 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3350 LOP(OP_DBMOPEN,XTERM);
3356 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3363 yylval.ival = PL_curcop->cop_line;
3377 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3378 UNIBRACK(OP_ENTEREVAL);
3393 case KEY_endhostent:
3399 case KEY_endservent:
3402 case KEY_endprotoent:
3413 yylval.ival = PL_curcop->cop_line;
3415 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3417 if ((PL_bufend - p) >= 3 &&
3418 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3422 croak("Missing $ on loop variable");
3427 LOP(OP_FORMLINE,XTERM);
3433 LOP(OP_FCNTL,XTERM);
3439 LOP(OP_FLOCK,XTERM);
3448 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3451 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3466 case KEY_getpriority:
3467 LOP(OP_GETPRIORITY,XTERM);
3469 case KEY_getprotobyname:
3472 case KEY_getprotobynumber:
3473 LOP(OP_GPBYNUMBER,XTERM);
3475 case KEY_getprotoent:
3487 case KEY_getpeername:
3488 UNI(OP_GETPEERNAME);
3490 case KEY_gethostbyname:
3493 case KEY_gethostbyaddr:
3494 LOP(OP_GHBYADDR,XTERM);
3496 case KEY_gethostent:
3499 case KEY_getnetbyname:
3502 case KEY_getnetbyaddr:
3503 LOP(OP_GNBYADDR,XTERM);
3508 case KEY_getservbyname:
3509 LOP(OP_GSBYNAME,XTERM);
3511 case KEY_getservbyport:
3512 LOP(OP_GSBYPORT,XTERM);
3514 case KEY_getservent:
3517 case KEY_getsockname:
3518 UNI(OP_GETSOCKNAME);
3520 case KEY_getsockopt:
3521 LOP(OP_GSOCKOPT,XTERM);
3543 yylval.ival = PL_curcop->cop_line;
3547 LOP(OP_INDEX,XTERM);
3553 LOP(OP_IOCTL,XTERM);
3565 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3596 LOP(OP_LISTEN,XTERM);
3605 s = scan_pat(s,OP_MATCH);
3606 TERM(sublex_start());
3609 LOP(OP_MAPSTART,XREF);
3612 LOP(OP_MKDIR,XTERM);
3615 LOP(OP_MSGCTL,XTERM);
3618 LOP(OP_MSGGET,XTERM);
3621 LOP(OP_MSGRCV,XTERM);
3624 LOP(OP_MSGSND,XTERM);
3629 if (isIDFIRST(*s)) {
3630 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3631 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3632 if (!PL_in_my_stash) {
3635 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3642 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3649 if (PL_expect != XSTATE)
3650 yyerror("\"no\" not allowed in expression");
3651 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3652 s = force_version(s);
3661 if (isIDFIRST(*s)) {
3663 for (d = s; isALNUM(*d); d++) ;
3665 if (strchr("|&*+-=!?:.", *t))
3666 warn("Precedence problem: open %.*s should be open(%.*s)",
3672 yylval.ival = OP_OR;
3682 LOP(OP_OPEN_DIR,XTERM);
3685 checkcomma(s,PL_tokenbuf,"filehandle");
3689 checkcomma(s,PL_tokenbuf,"filehandle");
3708 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3712 LOP(OP_PIPE_OP,XTERM);
3717 missingterm((char*)0);
3718 yylval.ival = OP_CONST;
3719 TERM(sublex_start());
3727 missingterm((char*)0);
3728 if (PL_dowarn && SvLEN(PL_lex_stuff)) {
3729 d = SvPV_force(PL_lex_stuff, len);
3730 for (; len; --len, ++d) {
3732 warn("Possible attempt to separate words with commas");
3736 warn("Possible attempt to put comments in qw() list");
3742 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3743 PL_lex_stuff = Nullsv;
3746 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3749 yylval.ival = OP_SPLIT;
3753 PL_last_lop = PL_oldbufptr;
3754 PL_last_lop_op = OP_SPLIT;
3760 missingterm((char*)0);
3761 yylval.ival = OP_STRINGIFY;
3762 if (SvIVX(PL_lex_stuff) == '\'')
3763 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3764 TERM(sublex_start());
3767 s = scan_pat(s,OP_QR);
3768 TERM(sublex_start());
3773 missingterm((char*)0);
3774 yylval.ival = OP_BACKTICK;
3776 TERM(sublex_start());
3782 *PL_tokenbuf = '\0';
3783 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3784 if (isIDFIRST(*PL_tokenbuf))
3785 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3787 yyerror("<> should be quotes");
3794 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3798 LOP(OP_RENAME,XTERM);
3807 LOP(OP_RINDEX,XTERM);
3830 LOP(OP_REVERSE,XTERM);
3841 TERM(sublex_start());
3843 TOKEN(1); /* force error */
3852 LOP(OP_SELECT,XTERM);
3858 LOP(OP_SEMCTL,XTERM);
3861 LOP(OP_SEMGET,XTERM);
3864 LOP(OP_SEMOP,XTERM);
3870 LOP(OP_SETPGRP,XTERM);
3872 case KEY_setpriority:
3873 LOP(OP_SETPRIORITY,XTERM);
3875 case KEY_sethostent:
3881 case KEY_setservent:
3884 case KEY_setprotoent:
3894 LOP(OP_SEEKDIR,XTERM);
3896 case KEY_setsockopt:
3897 LOP(OP_SSOCKOPT,XTERM);
3903 LOP(OP_SHMCTL,XTERM);
3906 LOP(OP_SHMGET,XTERM);
3909 LOP(OP_SHMREAD,XTERM);
3912 LOP(OP_SHMWRITE,XTERM);
3915 LOP(OP_SHUTDOWN,XTERM);
3924 LOP(OP_SOCKET,XTERM);
3926 case KEY_socketpair:
3927 LOP(OP_SOCKPAIR,XTERM);
3930 checkcomma(s,PL_tokenbuf,"subroutine name");
3932 if (*s == ';' || *s == ')') /* probably a close */
3933 croak("sort is now a reserved word");
3935 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3939 LOP(OP_SPLIT,XTERM);
3942 LOP(OP_SPRINTF,XTERM);
3945 LOP(OP_SPLICE,XTERM);
3961 LOP(OP_SUBSTR,XTERM);
3968 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3969 char tmpbuf[sizeof PL_tokenbuf];
3971 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3972 if (strchr(tmpbuf, ':'))
3973 sv_setpv(PL_subname, tmpbuf);
3975 sv_setsv(PL_subname,PL_curstname);
3976 sv_catpvn(PL_subname,"::",2);
3977 sv_catpvn(PL_subname,tmpbuf,len);
3979 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3983 PL_expect = XTERMBLOCK;
3984 sv_setpv(PL_subname,"?");
3987 if (tmp == KEY_format) {
3990 PL_lex_formbrack = PL_lex_brackets + 1;
3994 /* Look for a prototype */
4001 SvREFCNT_dec(PL_lex_stuff);
4002 PL_lex_stuff = Nullsv;
4003 croak("Prototype not terminated");
4006 d = SvPVX(PL_lex_stuff);
4008 for (p = d; *p; ++p) {
4013 SvCUR(PL_lex_stuff) = tmp;
4016 PL_nextval[1] = PL_nextval[0];
4017 PL_nexttype[1] = PL_nexttype[0];
4018 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4019 PL_nexttype[0] = THING;
4020 if (PL_nexttoke == 1) {
4021 PL_lex_defer = PL_lex_state;
4022 PL_lex_expect = PL_expect;
4023 PL_lex_state = LEX_KNOWNEXT;
4025 PL_lex_stuff = Nullsv;
4028 if (*SvPV(PL_subname,PL_na) == '?') {
4029 sv_setpv(PL_subname,"__ANON__");
4036 LOP(OP_SYSTEM,XREF);
4039 LOP(OP_SYMLINK,XTERM);
4042 LOP(OP_SYSCALL,XTERM);
4045 LOP(OP_SYSOPEN,XTERM);
4048 LOP(OP_SYSSEEK,XTERM);
4051 LOP(OP_SYSREAD,XTERM);
4054 LOP(OP_SYSWRITE,XTERM);
4058 TERM(sublex_start());
4079 LOP(OP_TRUNCATE,XTERM);
4091 yylval.ival = PL_curcop->cop_line;
4095 yylval.ival = PL_curcop->cop_line;
4099 LOP(OP_UNLINK,XTERM);
4105 LOP(OP_UNPACK,XTERM);
4108 LOP(OP_UTIME,XTERM);
4112 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4113 if (*d != '0' && isDIGIT(*d))
4114 yywarn("umask: argument is missing initial 0");
4119 LOP(OP_UNSHIFT,XTERM);
4122 if (PL_expect != XSTATE)
4123 yyerror("\"use\" not allowed in expression");
4126 s = force_version(s);
4127 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4128 PL_nextval[PL_nexttoke].opval = Nullop;
4133 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4134 s = force_version(s);
4147 yylval.ival = PL_curcop->cop_line;
4151 PL_hints |= HINT_BLOCK_SCOPE;
4158 LOP(OP_WAITPID,XTERM);
4166 static char ctl_l[2];
4168 if (ctl_l[0] == '\0')
4169 ctl_l[0] = toCTRL('L');
4170 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4173 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4178 if (PL_expect == XOPERATOR)
4184 yylval.ival = OP_XOR;
4189 TERM(sublex_start());
4195 keyword(register char *d, I32 len)
4200 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4201 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4202 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4203 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4204 if (strEQ(d,"__END__")) return KEY___END__;
4208 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4213 if (strEQ(d,"and")) return -KEY_and;
4214 if (strEQ(d,"abs")) return -KEY_abs;
4217 if (strEQ(d,"alarm")) return -KEY_alarm;
4218 if (strEQ(d,"atan2")) return -KEY_atan2;
4221 if (strEQ(d,"accept")) return -KEY_accept;
4226 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4229 if (strEQ(d,"bless")) return -KEY_bless;
4230 if (strEQ(d,"bind")) return -KEY_bind;
4231 if (strEQ(d,"binmode")) return -KEY_binmode;
4234 if (strEQ(d,"CORE")) return -KEY_CORE;
4239 if (strEQ(d,"cmp")) return -KEY_cmp;
4240 if (strEQ(d,"chr")) return -KEY_chr;
4241 if (strEQ(d,"cos")) return -KEY_cos;
4244 if (strEQ(d,"chop")) return KEY_chop;
4247 if (strEQ(d,"close")) return -KEY_close;
4248 if (strEQ(d,"chdir")) return -KEY_chdir;
4249 if (strEQ(d,"chomp")) return KEY_chomp;
4250 if (strEQ(d,"chmod")) return -KEY_chmod;
4251 if (strEQ(d,"chown")) return -KEY_chown;
4252 if (strEQ(d,"crypt")) return -KEY_crypt;
4255 if (strEQ(d,"chroot")) return -KEY_chroot;
4256 if (strEQ(d,"caller")) return -KEY_caller;
4259 if (strEQ(d,"connect")) return -KEY_connect;
4262 if (strEQ(d,"closedir")) return -KEY_closedir;
4263 if (strEQ(d,"continue")) return -KEY_continue;
4268 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4273 if (strEQ(d,"do")) return KEY_do;
4276 if (strEQ(d,"die")) return -KEY_die;
4279 if (strEQ(d,"dump")) return -KEY_dump;
4282 if (strEQ(d,"delete")) return KEY_delete;
4285 if (strEQ(d,"defined")) return KEY_defined;
4286 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4289 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4294 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4295 if (strEQ(d,"END")) return KEY_END;
4300 if (strEQ(d,"eq")) return -KEY_eq;
4303 if (strEQ(d,"eof")) return -KEY_eof;
4304 if (strEQ(d,"exp")) return -KEY_exp;
4307 if (strEQ(d,"else")) return KEY_else;
4308 if (strEQ(d,"exit")) return -KEY_exit;
4309 if (strEQ(d,"eval")) return KEY_eval;
4310 if (strEQ(d,"exec")) return -KEY_exec;
4311 if (strEQ(d,"each")) return KEY_each;
4314 if (strEQ(d,"elsif")) return KEY_elsif;
4317 if (strEQ(d,"exists")) return KEY_exists;
4318 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4321 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4322 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4325 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4328 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4329 if (strEQ(d,"endservent")) return -KEY_endservent;
4332 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4339 if (strEQ(d,"for")) return KEY_for;
4342 if (strEQ(d,"fork")) return -KEY_fork;
4345 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4346 if (strEQ(d,"flock")) return -KEY_flock;
4349 if (strEQ(d,"format")) return KEY_format;
4350 if (strEQ(d,"fileno")) return -KEY_fileno;
4353 if (strEQ(d,"foreach")) return KEY_foreach;
4356 if (strEQ(d,"formline")) return -KEY_formline;
4362 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4363 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4367 if (strnEQ(d,"get",3)) {
4372 if (strEQ(d,"ppid")) return -KEY_getppid;
4373 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4376 if (strEQ(d,"pwent")) return -KEY_getpwent;
4377 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4378 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4381 if (strEQ(d,"peername")) return -KEY_getpeername;
4382 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4383 if (strEQ(d,"priority")) return -KEY_getpriority;
4386 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4389 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4393 else if (*d == 'h') {
4394 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4395 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4396 if (strEQ(d,"hostent")) return -KEY_gethostent;
4398 else if (*d == 'n') {
4399 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4400 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4401 if (strEQ(d,"netent")) return -KEY_getnetent;
4403 else if (*d == 's') {
4404 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4405 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4406 if (strEQ(d,"servent")) return -KEY_getservent;
4407 if (strEQ(d,"sockname")) return -KEY_getsockname;
4408 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4410 else if (*d == 'g') {
4411 if (strEQ(d,"grent")) return -KEY_getgrent;
4412 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4413 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4415 else if (*d == 'l') {
4416 if (strEQ(d,"login")) return -KEY_getlogin;
4418 else if (strEQ(d,"c")) return -KEY_getc;
4423 if (strEQ(d,"gt")) return -KEY_gt;
4424 if (strEQ(d,"ge")) return -KEY_ge;
4427 if (strEQ(d,"grep")) return KEY_grep;
4428 if (strEQ(d,"goto")) return KEY_goto;
4429 if (strEQ(d,"glob")) return KEY_glob;
4432 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4437 if (strEQ(d,"hex")) return -KEY_hex;
4440 if (strEQ(d,"INIT")) return KEY_INIT;
4445 if (strEQ(d,"if")) return KEY_if;
4448 if (strEQ(d,"int")) return -KEY_int;
4451 if (strEQ(d,"index")) return -KEY_index;
4452 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4457 if (strEQ(d,"join")) return -KEY_join;
4461 if (strEQ(d,"keys")) return KEY_keys;
4462 if (strEQ(d,"kill")) return -KEY_kill;
4467 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4468 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4474 if (strEQ(d,"lt")) return -KEY_lt;
4475 if (strEQ(d,"le")) return -KEY_le;
4476 if (strEQ(d,"lc")) return -KEY_lc;
4479 if (strEQ(d,"log")) return -KEY_log;
4482 if (strEQ(d,"last")) return KEY_last;
4483 if (strEQ(d,"link")) return -KEY_link;
4484 if (strEQ(d,"lock")) return -KEY_lock;
4487 if (strEQ(d,"local")) return KEY_local;
4488 if (strEQ(d,"lstat")) return -KEY_lstat;
4491 if (strEQ(d,"length")) return -KEY_length;
4492 if (strEQ(d,"listen")) return -KEY_listen;
4495 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4498 if (strEQ(d,"localtime")) return -KEY_localtime;
4504 case 1: return KEY_m;
4506 if (strEQ(d,"my")) return KEY_my;
4509 if (strEQ(d,"map")) return KEY_map;
4512 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4515 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4516 if (strEQ(d,"msgget")) return -KEY_msgget;
4517 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4518 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4523 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4526 if (strEQ(d,"next")) return KEY_next;
4527 if (strEQ(d,"ne")) return -KEY_ne;
4528 if (strEQ(d,"not")) return -KEY_not;
4529 if (strEQ(d,"no")) return KEY_no;
4534 if (strEQ(d,"or")) return -KEY_or;
4537 if (strEQ(d,"ord")) return -KEY_ord;
4538 if (strEQ(d,"oct")) return -KEY_oct;
4539 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4543 if (strEQ(d,"open")) return -KEY_open;
4546 if (strEQ(d,"opendir")) return -KEY_opendir;
4553 if (strEQ(d,"pop")) return KEY_pop;
4554 if (strEQ(d,"pos")) return KEY_pos;
4557 if (strEQ(d,"push")) return KEY_push;
4558 if (strEQ(d,"pack")) return -KEY_pack;
4559 if (strEQ(d,"pipe")) return -KEY_pipe;
4562 if (strEQ(d,"print")) return KEY_print;
4565 if (strEQ(d,"printf")) return KEY_printf;
4568 if (strEQ(d,"package")) return KEY_package;
4571 if (strEQ(d,"prototype")) return KEY_prototype;
4576 if (strEQ(d,"q")) return KEY_q;
4577 if (strEQ(d,"qr")) return KEY_qr;
4578 if (strEQ(d,"qq")) return KEY_qq;
4579 if (strEQ(d,"qw")) return KEY_qw;
4580 if (strEQ(d,"qx")) return KEY_qx;
4582 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4587 if (strEQ(d,"ref")) return -KEY_ref;
4590 if (strEQ(d,"read")) return -KEY_read;
4591 if (strEQ(d,"rand")) return -KEY_rand;
4592 if (strEQ(d,"recv")) return -KEY_recv;
4593 if (strEQ(d,"redo")) return KEY_redo;
4596 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4597 if (strEQ(d,"reset")) return -KEY_reset;
4600 if (strEQ(d,"return")) return KEY_return;
4601 if (strEQ(d,"rename")) return -KEY_rename;
4602 if (strEQ(d,"rindex")) return -KEY_rindex;
4605 if (strEQ(d,"require")) return -KEY_require;
4606 if (strEQ(d,"reverse")) return -KEY_reverse;
4607 if (strEQ(d,"readdir")) return -KEY_readdir;
4610 if (strEQ(d,"readlink")) return -KEY_readlink;
4611 if (strEQ(d,"readline")) return -KEY_readline;
4612 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4615 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4621 case 0: return KEY_s;
4623 if (strEQ(d,"scalar")) return KEY_scalar;
4628 if (strEQ(d,"seek")) return -KEY_seek;
4629 if (strEQ(d,"send")) return -KEY_send;
4632 if (strEQ(d,"semop")) return -KEY_semop;
4635 if (strEQ(d,"select")) return -KEY_select;
4636 if (strEQ(d,"semctl")) return -KEY_semctl;
4637 if (strEQ(d,"semget")) return -KEY_semget;
4640 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4641 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4644 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4645 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4648 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4651 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4652 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4653 if (strEQ(d,"setservent")) return -KEY_setservent;
4656 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4657 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4664 if (strEQ(d,"shift")) return KEY_shift;
4667 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4668 if (strEQ(d,"shmget")) return -KEY_shmget;
4671 if (strEQ(d,"shmread")) return -KEY_shmread;
4674 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4675 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4680 if (strEQ(d,"sin")) return -KEY_sin;
4683 if (strEQ(d,"sleep")) return -KEY_sleep;
4686 if (strEQ(d,"sort")) return KEY_sort;
4687 if (strEQ(d,"socket")) return -KEY_socket;
4688 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4691 if (strEQ(d,"split")) return KEY_split;
4692 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4693 if (strEQ(d,"splice")) return KEY_splice;
4696 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4699 if (strEQ(d,"srand")) return -KEY_srand;
4702 if (strEQ(d,"stat")) return -KEY_stat;
4703 if (strEQ(d,"study")) return KEY_study;
4706 if (strEQ(d,"substr")) return -KEY_substr;
4707 if (strEQ(d,"sub")) return KEY_sub;
4712 if (strEQ(d,"system")) return -KEY_system;
4715 if (strEQ(d,"symlink")) return -KEY_symlink;
4716 if (strEQ(d,"syscall")) return -KEY_syscall;
4717 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4718 if (strEQ(d,"sysread")) return -KEY_sysread;
4719 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4722 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4731 if (strEQ(d,"tr")) return KEY_tr;
4734 if (strEQ(d,"tie")) return KEY_tie;
4737 if (strEQ(d,"tell")) return -KEY_tell;
4738 if (strEQ(d,"tied")) return KEY_tied;
4739 if (strEQ(d,"time")) return -KEY_time;
4742 if (strEQ(d,"times")) return -KEY_times;
4745 if (strEQ(d,"telldir")) return -KEY_telldir;
4748 if (strEQ(d,"truncate")) return -KEY_truncate;
4755 if (strEQ(d,"uc")) return -KEY_uc;
4758 if (strEQ(d,"use")) return KEY_use;
4761 if (strEQ(d,"undef")) return KEY_undef;
4762 if (strEQ(d,"until")) return KEY_until;
4763 if (strEQ(d,"untie")) return KEY_untie;
4764 if (strEQ(d,"utime")) return -KEY_utime;
4765 if (strEQ(d,"umask")) return -KEY_umask;
4768 if (strEQ(d,"unless")) return KEY_unless;
4769 if (strEQ(d,"unpack")) return -KEY_unpack;
4770 if (strEQ(d,"unlink")) return -KEY_unlink;
4773 if (strEQ(d,"unshift")) return KEY_unshift;
4774 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4779 if (strEQ(d,"values")) return -KEY_values;
4780 if (strEQ(d,"vec")) return -KEY_vec;
4785 if (strEQ(d,"warn")) return -KEY_warn;
4786 if (strEQ(d,"wait")) return -KEY_wait;
4789 if (strEQ(d,"while")) return KEY_while;
4790 if (strEQ(d,"write")) return -KEY_write;
4793 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4796 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4801 if (len == 1) return -KEY_x;
4802 if (strEQ(d,"xor")) return -KEY_xor;
4805 if (len == 1) return KEY_y;
4814 checkcomma(register char *s, char *name, char *what)
4818 if (PL_dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4820 for (w = s+2; *w && level; w++) {
4827 for (; *w && isSPACE(*w); w++) ;
4828 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4829 warn("%s (...) interpreted as function",name);
4831 while (s < PL_bufend && isSPACE(*s))
4835 while (s < PL_bufend && isSPACE(*s))
4837 if (isIDFIRST(*s)) {
4841 while (s < PL_bufend && isSPACE(*s))
4846 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4850 croak("No comma allowed after %s", what);
4856 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4859 HV *table = GvHV(PL_hintgv); /* ^H */
4862 bool oldcatch = CATCH_GET;
4868 yyerror("%^H is not defined");
4871 cvp = hv_fetch(table, key, strlen(key), FALSE);
4872 if (!cvp || !SvOK(*cvp)) {
4873 sprintf(buf,"$^H{%s} is not defined", key);
4877 sv_2mortal(sv); /* Parent created it permanently */
4880 pv = sv_2mortal(newSVpv(s, len));
4882 typesv = sv_2mortal(newSVpv(type, 0));
4884 typesv = &PL_sv_undef;
4886 Zero(&myop, 1, BINOP);
4887 myop.op_last = (OP *) &myop;
4888 myop.op_next = Nullop;
4889 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4891 PUSHSTACKi(PERLSI_OVERLOAD);
4894 PL_op = (OP *) &myop;
4895 if (PERLDB_SUB && PL_curstash != PL_debstash)
4896 PL_op->op_private |= OPpENTERSUB_DB;
4907 if (PL_op = pp_entersub(ARGS))
4914 CATCH_SET(oldcatch);
4918 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4921 return SvREFCNT_inc(res);
4925 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4927 register char *d = dest;
4928 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4931 croak(ident_too_long);
4934 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4939 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4943 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8(s)) {
4944 char *t = s + UTF8SKIP(s);
4945 while (*t & 0x80 && is_utf8_mark(t))
4947 if (d + (t - s) > e)
4948 croak(ident_too_long);
4949 Copy(s, d, t - s, char);
4962 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4969 if (PL_lex_brackets == 0)
4970 PL_lex_fakebrack = 0;
4974 e = d + destlen - 3; /* two-character token, ending NUL */
4976 while (isDIGIT(*s)) {
4978 croak(ident_too_long);
4985 croak(ident_too_long);
4988 else if (*s == '\'' && isIDFIRST(s[1])) {
4993 else if (*s == ':' && s[1] == ':') {
4997 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8(s)) {
4998 char *t = s + UTF8SKIP(s);
4999 while (*t & 0x80 && is_utf8_mark(t))
5001 if (d + (t - s) > e)
5002 croak(ident_too_long);
5003 Copy(s, d, t - s, char);
5014 if (PL_lex_state != LEX_NORMAL)
5015 PL_lex_state = LEX_INTERPENDMAYBE;
5018 if (*s == '$' && s[1] &&
5019 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5021 if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
5022 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
5035 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5040 if (isSPACE(s[-1])) {
5043 if (ch != ' ' && ch != '\t') {
5049 if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8(d))) {
5053 while (e < send && (isALNUM(*e) || ((*e & 0xc0) == 0x80 && isALNUM_utf8((U8*)e)) || *e == ':')) {
5055 while (e < send && *e & 0x80 && is_utf8_mark(e))
5058 Copy(s, d, e - s, char);
5063 while (isALNUM(*s) || *s == ':')
5067 while (s < send && (*s == ' ' || *s == '\t')) s++;
5068 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5069 if (PL_dowarn && keyword(dest, d - dest)) {
5070 char *brack = *s == '[' ? "[...]" : "{...}";
5071 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
5072 funny, dest, brack, funny, dest, brack);
5074 PL_lex_fakebrack = PL_lex_brackets+1;
5076 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5082 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5083 PL_lex_state = LEX_INTERPEND;
5086 if (PL_dowarn && PL_lex_state == LEX_NORMAL &&
5087 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5088 warn("Ambiguous use of %c{%s} resolved to %c%s",
5089 funny, dest, funny, dest);
5092 s = bracket; /* let the parser handle it */
5096 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5097 PL_lex_state = LEX_INTERPEND;
5101 void pmflag(U16 *pmfl, int ch)
5106 *pmfl |= PMf_GLOBAL;
5108 *pmfl |= PMf_CONTINUE;
5112 *pmfl |= PMf_MULTILINE;
5114 *pmfl |= PMf_SINGLELINE;
5116 *pmfl |= PMf_EXTENDED;
5120 scan_pat(char *start, I32 type)
5125 s = scan_str(start);
5128 SvREFCNT_dec(PL_lex_stuff);
5129 PL_lex_stuff = Nullsv;
5130 croak("Search pattern not terminated");
5133 pm = (PMOP*)newPMOP(type, 0);
5134 if (PL_multi_open == '?')
5135 pm->op_pmflags |= PMf_ONCE;
5137 while (*s && strchr("iomsx", *s))
5138 pmflag(&pm->op_pmflags,*s++);
5141 while (*s && strchr("iogcmsx", *s))
5142 pmflag(&pm->op_pmflags,*s++);
5144 pm->op_pmpermflags = pm->op_pmflags;
5146 PL_lex_op = (OP*)pm;
5147 yylval.ival = OP_MATCH;
5152 scan_subst(char *start)
5159 yylval.ival = OP_NULL;
5161 s = scan_str(start);
5165 SvREFCNT_dec(PL_lex_stuff);
5166 PL_lex_stuff = Nullsv;
5167 croak("Substitution pattern not terminated");
5170 if (s[-1] == PL_multi_open)
5173 first_start = PL_multi_start;
5177 SvREFCNT_dec(PL_lex_stuff);
5178 PL_lex_stuff = Nullsv;
5180 SvREFCNT_dec(PL_lex_repl);
5181 PL_lex_repl = Nullsv;
5182 croak("Substitution replacement not terminated");
5184 PL_multi_start = first_start; /* so whole substitution is taken together */
5186 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5192 else if (strchr("iogcmsx", *s))
5193 pmflag(&pm->op_pmflags,*s++);
5200 pm->op_pmflags |= PMf_EVAL;
5201 repl = newSVpv("",0);
5203 sv_catpv(repl, es ? "eval " : "do ");
5204 sv_catpvn(repl, "{ ", 2);
5205 sv_catsv(repl, PL_lex_repl);
5206 sv_catpvn(repl, " };", 2);
5207 SvCOMPILED_on(repl);
5208 SvREFCNT_dec(PL_lex_repl);
5212 pm->op_pmpermflags = pm->op_pmflags;
5213 PL_lex_op = (OP*)pm;
5214 yylval.ival = OP_SUBST;
5219 scan_trans(char *start)
5230 yylval.ival = OP_NULL;
5232 s = scan_str(start);
5235 SvREFCNT_dec(PL_lex_stuff);
5236 PL_lex_stuff = Nullsv;
5237 croak("Transliteration pattern not terminated");
5239 if (s[-1] == PL_multi_open)
5245 SvREFCNT_dec(PL_lex_stuff);
5246 PL_lex_stuff = Nullsv;
5248 SvREFCNT_dec(PL_lex_repl);
5249 PL_lex_repl = Nullsv;
5250 croak("Transliteration replacement not terminated");
5254 o = newSVOP(OP_TRANS, 0, 0);
5255 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5258 New(803,tbl,256,short);
5259 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5263 complement = del = squash = 0;
5264 while (strchr("cdsCU", *s)) {
5266 complement = OPpTRANS_COMPLEMENT;
5268 del = OPpTRANS_DELETE;
5270 squash = OPpTRANS_SQUASH;
5275 utf8 &= ~OPpTRANS_FROM_UTF;
5277 utf8 |= OPpTRANS_FROM_UTF;
5281 utf8 &= ~OPpTRANS_TO_UTF;
5283 utf8 |= OPpTRANS_TO_UTF;
5286 croak("Too many /C and /U options");
5291 o->op_private = del|squash|complement|utf8;
5294 yylval.ival = OP_TRANS;
5299 scan_heredoc(register char *s)
5303 I32 op_type = OP_SCALAR;
5310 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5314 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5317 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5318 if (*peek && strchr("`'\"",*peek)) {
5321 s = delimcpy(d, e, s, PL_bufend, term, &len);
5332 deprecate("bare << to mean <<\"\"");
5333 for (; isALNUM(*s); s++) {
5338 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5339 croak("Delimiter for here document is too long");
5342 len = d - PL_tokenbuf;
5343 #ifndef PERL_STRICT_CR
5344 d = strchr(s, '\r');
5348 while (s < PL_bufend) {
5354 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5363 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5368 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5369 herewas = newSVpv(s,PL_bufend-s);
5371 s--, herewas = newSVpv(s,d-s);
5372 s += SvCUR(herewas);
5374 tmpstr = NEWSV(87,79);
5375 sv_upgrade(tmpstr, SVt_PVIV);
5380 else if (term == '`') {
5381 op_type = OP_BACKTICK;
5382 SvIVX(tmpstr) = '\\';
5386 PL_multi_start = PL_curcop->cop_line;
5387 PL_multi_open = PL_multi_close = '<';
5388 term = *PL_tokenbuf;
5391 while (s < PL_bufend &&
5392 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5394 PL_curcop->cop_line++;
5396 if (s >= PL_bufend) {
5397 PL_curcop->cop_line = PL_multi_start;
5398 missingterm(PL_tokenbuf);
5400 sv_setpvn(tmpstr,d+1,s-d);
5402 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5404 sv_catpvn(herewas,s,PL_bufend-s);
5405 sv_setsv(PL_linestr,herewas);
5406 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5407 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5410 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5411 while (s >= PL_bufend) { /* multiple line string? */
5413 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5414 PL_curcop->cop_line = PL_multi_start;
5415 missingterm(PL_tokenbuf);
5417 PL_curcop->cop_line++;
5418 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5419 #ifndef PERL_STRICT_CR
5420 if (PL_bufend - PL_linestart >= 2) {
5421 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5422 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5424 PL_bufend[-2] = '\n';
5426 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5428 else if (PL_bufend[-1] == '\r')
5429 PL_bufend[-1] = '\n';
5431 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5432 PL_bufend[-1] = '\n';
5434 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5435 SV *sv = NEWSV(88,0);
5437 sv_upgrade(sv, SVt_PVMG);
5438 sv_setsv(sv,PL_linestr);
5439 av_store(GvAV(PL_curcop->cop_filegv),
5440 (I32)PL_curcop->cop_line,sv);
5442 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5445 sv_catsv(PL_linestr,herewas);
5446 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5450 sv_catsv(tmpstr,PL_linestr);
5453 PL_multi_end = PL_curcop->cop_line;
5455 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5456 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5457 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5459 SvREFCNT_dec(herewas);
5460 PL_lex_stuff = tmpstr;
5461 yylval.ival = op_type;
5466 takes: current position in input buffer
5467 returns: new position in input buffer
5468 side-effects: yylval and lex_op are set.
5473 <FH> read from filehandle
5474 <pkg::FH> read from package qualified filehandle
5475 <pkg'FH> read from package qualified filehandle
5476 <$fh> read from filehandle in $fh
5482 scan_inputsymbol(char *start)
5484 register char *s = start; /* current position in buffer */
5489 d = PL_tokenbuf; /* start of temp holding space */
5490 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5491 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5493 /* die if we didn't have space for the contents of the <>,
5497 if (len >= sizeof PL_tokenbuf)
5498 croak("Excessively long <> operator");
5500 croak("Unterminated <> operator");
5505 Remember, only scalar variables are interpreted as filehandles by
5506 this code. Anything more complex (e.g., <$fh{$num}>) will be
5507 treated as a glob() call.
5508 This code makes use of the fact that except for the $ at the front,
5509 a scalar variable and a filehandle look the same.
5511 if (*d == '$' && d[1]) d++;
5513 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5514 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5517 /* If we've tried to read what we allow filehandles to look like, and
5518 there's still text left, then it must be a glob() and not a getline.
5519 Use scan_str to pull out the stuff between the <> and treat it
5520 as nothing more than a string.
5523 if (d - PL_tokenbuf != len) {
5524 yylval.ival = OP_GLOB;
5526 s = scan_str(start);
5528 croak("Glob not terminated");
5532 /* we're in a filehandle read situation */
5535 /* turn <> into <ARGV> */
5537 (void)strcpy(d,"ARGV");
5539 /* if <$fh>, create the ops to turn the variable into a
5545 /* try to find it in the pad for this block, otherwise find
5546 add symbol table ops
5548 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5549 OP *o = newOP(OP_PADSV, 0);
5551 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5554 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5555 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5556 newUNOP(OP_RV2GV, 0,
5557 newUNOP(OP_RV2SV, 0,
5558 newGVOP(OP_GV, 0, gv))));
5560 /* we created the ops in lex_op, so make yylval.ival a null op */
5561 yylval.ival = OP_NULL;
5564 /* If it's none of the above, it must be a literal filehandle
5565 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5567 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5568 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5569 yylval.ival = OP_NULL;
5578 takes: start position in buffer
5579 returns: position to continue reading from buffer
5580 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5581 updates the read buffer.
5583 This subroutine pulls a string out of the input. It is called for:
5584 q single quotes q(literal text)
5585 ' single quotes 'literal text'
5586 qq double quotes qq(interpolate $here please)
5587 " double quotes "interpolate $here please"
5588 qx backticks qx(/bin/ls -l)
5589 ` backticks `/bin/ls -l`
5590 qw quote words @EXPORT_OK = qw( func() $spam )
5591 m// regexp match m/this/
5592 s/// regexp substitute s/this/that/
5593 tr/// string transliterate tr/this/that/
5594 y/// string transliterate y/this/that/
5595 ($*@) sub prototypes sub foo ($)
5596 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5598 In most of these cases (all but <>, patterns and transliterate)
5599 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5600 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5601 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5604 It skips whitespace before the string starts, and treats the first
5605 character as the delimiter. If the delimiter is one of ([{< then
5606 the corresponding "close" character )]}> is used as the closing
5607 delimiter. It allows quoting of delimiters, and if the string has
5608 balanced delimiters ([{<>}]) it allows nesting.
5610 The lexer always reads these strings into lex_stuff, except in the
5611 case of the operators which take *two* arguments (s/// and tr///)
5612 when it checks to see if lex_stuff is full (presumably with the 1st
5613 arg to s or tr) and if so puts the string into lex_repl.
5618 scan_str(char *start)
5621 SV *sv; /* scalar value: string */
5622 char *tmps; /* temp string, used for delimiter matching */
5623 register char *s = start; /* current position in the buffer */
5624 register char term; /* terminating character */
5625 register char *to; /* current position in the sv's data */
5626 I32 brackets = 1; /* bracket nesting level */
5628 /* skip space before the delimiter */
5632 /* mark where we are, in case we need to report errors */
5635 /* after skipping whitespace, the next character is the terminator */
5637 /* mark where we are */
5638 PL_multi_start = PL_curcop->cop_line;
5639 PL_multi_open = term;
5641 /* find corresponding closing delimiter */
5642 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5644 PL_multi_close = term;
5646 /* create a new SV to hold the contents. 87 is leak category, I'm
5647 assuming. 79 is the SV's initial length. What a random number. */
5649 sv_upgrade(sv, SVt_PVIV);
5651 (void)SvPOK_only(sv); /* validate pointer */
5653 /* move past delimiter and try to read a complete string */
5656 /* extend sv if need be */
5657 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5658 /* set 'to' to the next character in the sv's string */
5659 to = SvPVX(sv)+SvCUR(sv);
5661 /* if open delimiter is the close delimiter read unbridle */
5662 if (PL_multi_open == PL_multi_close) {
5663 for (; s < PL_bufend; s++,to++) {
5664 /* embedded newlines increment the current line number */
5665 if (*s == '\n' && !PL_rsfp)
5666 PL_curcop->cop_line++;
5667 /* handle quoted delimiters */
5668 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5671 /* any other quotes are simply copied straight through */
5675 /* terminate when run out of buffer (the for() condition), or
5676 have found the terminator */
5677 else if (*s == term)
5683 /* if the terminator isn't the same as the start character (e.g.,
5684 matched brackets), we have to allow more in the quoting, and
5685 be prepared for nested brackets.
5688 /* read until we run out of string, or we find the terminator */
5689 for (; s < PL_bufend; s++,to++) {
5690 /* embedded newlines increment the line count */
5691 if (*s == '\n' && !PL_rsfp)
5692 PL_curcop->cop_line++;
5693 /* backslashes can escape the open or closing characters */
5694 if (*s == '\\' && s+1 < PL_bufend) {
5695 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5700 /* allow nested opens and closes */
5701 else if (*s == PL_multi_close && --brackets <= 0)
5703 else if (*s == PL_multi_open)
5708 /* terminate the copied string and update the sv's end-of-string */
5710 SvCUR_set(sv, to - SvPVX(sv));
5713 * this next chunk reads more into the buffer if we're not done yet
5716 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5718 #ifndef PERL_STRICT_CR
5719 if (to - SvPVX(sv) >= 2) {
5720 if ((to[-2] == '\r' && to[-1] == '\n') ||
5721 (to[-2] == '\n' && to[-1] == '\r'))
5725 SvCUR_set(sv, to - SvPVX(sv));
5727 else if (to[-1] == '\r')
5730 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5734 /* if we're out of file, or a read fails, bail and reset the current
5735 line marker so we can report where the unterminated string began
5738 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5740 PL_curcop->cop_line = PL_multi_start;
5743 /* we read a line, so increment our line counter */
5744 PL_curcop->cop_line++;
5746 /* update debugger info */
5747 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5748 SV *sv = NEWSV(88,0);
5750 sv_upgrade(sv, SVt_PVMG);
5751 sv_setsv(sv,PL_linestr);
5752 av_store(GvAV(PL_curcop->cop_filegv),
5753 (I32)PL_curcop->cop_line, sv);
5756 /* having changed the buffer, we must update PL_bufend */
5757 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5760 /* at this point, we have successfully read the delimited string */
5762 PL_multi_end = PL_curcop->cop_line;
5765 /* if we allocated too much space, give some back */
5766 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5767 SvLEN_set(sv, SvCUR(sv) + 1);
5768 Renew(SvPVX(sv), SvLEN(sv), char);
5771 /* decide whether this is the first or second quoted string we've read
5784 takes: pointer to position in buffer
5785 returns: pointer to new position in buffer
5786 side-effects: builds ops for the constant in yylval.op
5788 Read a number in any of the formats that Perl accepts:
5790 0(x[0-7A-F]+)|([0-7]+)
5791 [\d_]+(\.[\d_]*)?[Ee](\d+)
5793 Underbars (_) are allowed in decimal numbers. If -w is on,
5794 underbars before a decimal point must be at three digit intervals.
5796 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5799 If it reads a number without a decimal point or an exponent, it will
5800 try converting the number to an integer and see if it can do so
5801 without loss of precision.
5805 scan_num(char *start)
5807 register char *s = start; /* current position in buffer */
5808 register char *d; /* destination in temp buffer */
5809 register char *e; /* end of temp buffer */
5810 I32 tryiv; /* used to see if it can be an int */
5811 double value; /* number read, as a double */
5812 SV *sv; /* place to put the converted number */
5813 I32 floatit; /* boolean: int or float? */
5814 char *lastub = 0; /* position of last underbar */
5815 static char number_too_long[] = "Number too long";
5817 /* We use the first character to decide what type of number this is */
5821 croak("panic: scan_num");
5823 /* if it starts with a 0, it could be an octal number, a decimal in
5824 0.13 disguise, or a hexadecimal number.
5829 u holds the "number so far"
5830 shift the power of 2 of the base (hex == 4, octal == 3)
5831 overflowed was the number more than we can hold?
5833 Shift is used when we add a digit. It also serves as an "are
5834 we in octal or hex?" indicator to disallow hex characters when
5839 bool overflowed = FALSE;
5846 /* check for a decimal in disguise */
5847 else if (s[1] == '.')
5849 /* so it must be octal */
5854 /* read the rest of the octal number */
5856 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5860 /* if we don't mention it, we're done */
5869 /* 8 and 9 are not octal */
5872 yyerror("Illegal octal digit");
5876 case '0': case '1': case '2': case '3': case '4':
5877 case '5': case '6': case '7':
5878 b = *s++ & 15; /* ASCII digit -> value of digit */
5882 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5883 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5884 /* make sure they said 0x */
5889 /* Prepare to put the digit we have onto the end
5890 of the number so far. We check for overflows.
5894 n = u << shift; /* make room for the digit */
5895 if (!overflowed && (n >> shift) != u
5896 && !(PL_hints & HINT_NEW_BINARY)) {
5897 warn("Integer overflow in %s number",
5898 (shift == 4) ? "hex" : "octal");
5901 u = n | b; /* add the digit to the end */
5906 /* if we get here, we had success: make a scalar value from
5912 if ( PL_hints & HINT_NEW_BINARY)
5913 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5918 handle decimal numbers.
5919 we're also sent here when we read a 0 as the first digit
5921 case '1': case '2': case '3': case '4': case '5':
5922 case '6': case '7': case '8': case '9': case '.':
5925 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5928 /* read next group of digits and _ and copy into d */
5929 while (isDIGIT(*s) || *s == '_') {
5930 /* skip underscores, checking for misplaced ones
5934 if (PL_dowarn && lastub && s - lastub != 3)
5935 warn("Misplaced _ in number");
5939 /* check for end of fixed-length buffer */
5941 croak(number_too_long);
5942 /* if we're ok, copy the character */
5947 /* final misplaced underbar check */
5948 if (PL_dowarn && lastub && s - lastub != 3)
5949 warn("Misplaced _ in number");
5951 /* read a decimal portion if there is one. avoid
5952 3..5 being interpreted as the number 3. followed
5955 if (*s == '.' && s[1] != '.') {
5959 /* copy, ignoring underbars, until we run out of
5960 digits. Note: no misplaced underbar checks!
5962 for (; isDIGIT(*s) || *s == '_'; s++) {
5963 /* fixed length buffer check */
5965 croak(number_too_long);
5971 /* read exponent part, if present */
5972 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5976 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5977 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5979 /* allow positive or negative exponent */
5980 if (*s == '+' || *s == '-')
5983 /* read digits of exponent (no underbars :-) */
5984 while (isDIGIT(*s)) {
5986 croak(number_too_long);
5991 /* terminate the string */
5994 /* make an sv from the string */
5996 /* reset numeric locale in case we were earlier left in Swaziland */
5997 SET_NUMERIC_STANDARD();
5998 value = atof(PL_tokenbuf);
6001 See if we can make do with an integer value without loss of
6002 precision. We use I_V to cast to an int, because some
6003 compilers have issues. Then we try casting it back and see
6004 if it was the same. We only do this if we know we
6005 specifically read an integer.
6007 Note: if floatit is true, then we don't need to do the
6011 if (!floatit && (double)tryiv == value)
6012 sv_setiv(sv, tryiv);
6014 sv_setnv(sv, value);
6015 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6016 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6017 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6021 /* make the op for the constant and return */
6023 yylval.opval = newSVOP(OP_CONST, 0, sv);
6029 scan_formline(register char *s)
6034 SV *stuff = newSVpv("",0);
6035 bool needargs = FALSE;
6038 if (*s == '.' || *s == '}') {
6040 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
6044 if (PL_in_eval && !PL_rsfp) {
6045 eol = strchr(s,'\n');
6050 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6052 for (t = s; t < eol; t++) {
6053 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6055 goto enough; /* ~~ must be first line in formline */
6057 if (*t == '@' || *t == '^')
6060 sv_catpvn(stuff, s, eol-s);
6064 s = filter_gets(PL_linestr, PL_rsfp, 0);
6065 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6066 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6069 yyerror("Format not terminated");
6079 PL_lex_state = LEX_NORMAL;
6080 PL_nextval[PL_nexttoke].ival = 0;
6084 PL_lex_state = LEX_FORMLINE;
6085 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6087 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6091 SvREFCNT_dec(stuff);
6092 PL_lex_formbrack = 0;
6103 PL_cshlen = strlen(PL_cshname);
6108 start_subparse(I32 is_format, U32 flags)
6111 I32 oldsavestack_ix = PL_savestack_ix;
6112 CV* outsidecv = PL_compcv;
6116 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6118 save_I32(&PL_subline);
6119 save_item(PL_subname);
6121 SAVESPTR(PL_curpad);
6122 SAVESPTR(PL_comppad);
6123 SAVESPTR(PL_comppad_name);
6124 SAVESPTR(PL_compcv);
6125 SAVEI32(PL_comppad_name_fill);
6126 SAVEI32(PL_min_intro_pending);
6127 SAVEI32(PL_max_intro_pending);
6128 SAVEI32(PL_pad_reset_pending);
6130 PL_compcv = (CV*)NEWSV(1104,0);
6131 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6132 CvFLAGS(PL_compcv) |= flags;
6134 PL_comppad = newAV();
6135 av_push(PL_comppad, Nullsv);
6136 PL_curpad = AvARRAY(PL_comppad);
6137 PL_comppad_name = newAV();
6138 PL_comppad_name_fill = 0;
6139 PL_min_intro_pending = 0;
6141 PL_subline = PL_curcop->cop_line;
6143 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6144 PL_curpad[0] = (SV*)newAV();
6145 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6146 #endif /* USE_THREADS */
6148 comppadlist = newAV();
6149 AvREAL_off(comppadlist);
6150 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6151 av_store(comppadlist, 1, (SV*)PL_comppad);
6153 CvPADLIST(PL_compcv) = comppadlist;
6154 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6156 CvOWNER(PL_compcv) = 0;
6157 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6158 MUTEX_INIT(CvMUTEXP(PL_compcv));
6159 #endif /* USE_THREADS */
6161 return oldsavestack_ix;
6180 char *context = NULL;
6184 if (!yychar || (yychar == ';' && !PL_rsfp))
6186 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6187 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6188 while (isSPACE(*PL_oldoldbufptr))
6190 context = PL_oldoldbufptr;
6191 contlen = PL_bufptr - PL_oldoldbufptr;
6193 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6194 PL_oldbufptr != PL_bufptr) {
6195 while (isSPACE(*PL_oldbufptr))
6197 context = PL_oldbufptr;
6198 contlen = PL_bufptr - PL_oldbufptr;
6200 else if (yychar > 255)
6201 where = "next token ???";
6202 else if ((yychar & 127) == 127) {
6203 if (PL_lex_state == LEX_NORMAL ||
6204 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6205 where = "at end of line";
6206 else if (PL_lex_inpat)
6207 where = "within pattern";
6209 where = "within string";
6212 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6214 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6215 else if (isPRINT_LC(yychar))
6216 sv_catpvf(where_sv, "%c", yychar);
6218 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6219 where = SvPVX(where_sv);
6221 msg = sv_2mortal(newSVpv(s, 0));
6222 sv_catpvf(msg, " at %_ line %ld, ",
6223 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6225 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6227 sv_catpvf(msg, "%s\n", where);
6228 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6230 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6231 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6236 else if (PL_in_eval)
6237 sv_catsv(ERRSV, msg);
6239 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6240 if (++PL_error_count >= 10)
6241 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6243 PL_in_my_stash = Nullhv;