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
14 #define TMP_CRLF_PATCH
20 static void check_uni _((void));
21 static void force_next _((I32 type));
22 static char *force_version _((char *start));
23 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
24 static SV *tokeq _((SV *sv));
25 static char *scan_const _((char *start));
26 static char *scan_formline _((char *s));
27 static char *scan_heredoc _((char *s));
28 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
30 static char *scan_inputsymbol _((char *start));
31 static char *scan_pat _((char *start, I32 type));
32 static char *scan_str _((char *start));
33 static char *scan_subst _((char *start));
34 static char *scan_trans _((char *start));
35 static char *scan_word _((char *s, char *dest, STRLEN destlen,
36 int allow_package, STRLEN *slp));
37 static char *skipspace _((char *s));
38 static void checkcomma _((char *s, char *name, char *what));
39 static void force_ident _((char *s, int kind));
40 static void incline _((char *s));
41 static int intuit_method _((char *s, GV *gv));
42 static int intuit_more _((char *s));
43 static I32 lop _((I32 f, expectation x, char *s));
44 static void missingterm _((char *s));
45 static void no_op _((char *what, char *s));
46 static void set_csh _((void));
47 static I32 sublex_done _((void));
48 static I32 sublex_push _((void));
49 static I32 sublex_start _((void));
51 static int uni _((I32 f, char *s));
53 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
54 static void restore_rsfp _((void *f));
55 static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
56 static void restore_expect _((void *e));
57 static void restore_lex_expect _((void *e));
58 #endif /* PERL_OBJECT */
60 static char ident_too_long[] = "Identifier too long";
62 #define UTF (PL_hints & HINT_UTF8)
64 /* The following are arranged oddly so that the guard on the switch statement
65 * can get by with a single comparison (if the compiler is smart enough).
68 /* #define LEX_NOTPARSING 11 is done in perl.h. */
71 #define LEX_INTERPNORMAL 9
72 #define LEX_INTERPCASEMOD 8
73 #define LEX_INTERPPUSH 7
74 #define LEX_INTERPSTART 6
75 #define LEX_INTERPEND 5
76 #define LEX_INTERPENDMAYBE 4
77 #define LEX_INTERPCONCAT 3
78 #define LEX_INTERPCONST 2
79 #define LEX_FORMLINE 1
80 #define LEX_KNOWNEXT 0
89 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
91 # include <unistd.h> /* Needed for execv() */
104 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
106 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
107 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
108 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
109 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
110 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
111 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
112 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
113 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
114 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
115 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
116 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
117 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
118 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
119 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
120 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
121 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
122 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
123 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
124 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
125 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
127 /* This bit of chicanery makes a unary function followed by
128 * a parenthesis into a function with one argument, highest precedence.
130 #define UNI(f) return(yylval.ival = f, \
133 PL_last_uni = PL_oldbufptr, \
134 PL_last_lop_op = f, \
135 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
137 #define UNIBRACK(f) return(yylval.ival = f, \
139 PL_last_uni = PL_oldbufptr, \
140 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
142 /* grandfather return to old style */
143 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
148 if (*PL_bufptr == '=') {
150 if (toketype == ANDAND)
151 yylval.ival = OP_ANDASSIGN;
152 else if (toketype == OROR)
153 yylval.ival = OP_ORASSIGN;
160 no_op(char *what, char *s)
162 char *oldbp = PL_bufptr;
163 bool is_first = (PL_oldbufptr == PL_linestart);
166 yywarn(form("%s found where operator expected", what));
168 warn("\t(Missing semicolon on previous line?)\n");
169 else if (PL_oldoldbufptr && isIDFIRST(*PL_oldoldbufptr)) {
171 for (t = PL_oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
172 if (t < PL_bufptr && isSPACE(*t))
173 warn("\t(Do you need to predeclare %.*s?)\n",
174 t - PL_oldoldbufptr, PL_oldoldbufptr);
178 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
188 char *nl = strrchr(s,'\n');
192 else if (PL_multi_close < 32 || PL_multi_close == 127) {
194 tmpbuf[1] = toCTRL(PL_multi_close);
200 *tmpbuf = PL_multi_close;
204 q = strchr(s,'"') ? '\'' : '"';
205 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
212 warn("Use of %s is deprecated", s);
218 deprecate("comma-less variable list");
224 win32_textfilter(int idx, SV *sv, int maxlen)
226 I32 count = FILTER_READ(idx+1, sv, maxlen);
227 if (count > 0 && !maxlen)
228 win32_strip_return(sv);
234 utf16_textfilter(int idx, SV *sv, int maxlen)
236 I32 count = FILTER_READ(idx+1, sv, maxlen);
240 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, char);
241 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
242 sv_usepvn(sv, tmps, tend - tmps);
249 utf16rev_textfilter(int idx, SV *sv, int maxlen)
251 I32 count = FILTER_READ(idx+1, sv, maxlen);
255 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, char);
256 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
257 sv_usepvn(sv, tmps, tend - tmps);
270 SAVEI32(PL_lex_dojoin);
271 SAVEI32(PL_lex_brackets);
272 SAVEI32(PL_lex_fakebrack);
273 SAVEI32(PL_lex_casemods);
274 SAVEI32(PL_lex_starts);
275 SAVEI32(PL_lex_state);
276 SAVESPTR(PL_lex_inpat);
277 SAVEI32(PL_lex_inwhat);
278 SAVEI16(PL_curcop->cop_line);
281 SAVEPPTR(PL_oldbufptr);
282 SAVEPPTR(PL_oldoldbufptr);
283 SAVEPPTR(PL_linestart);
284 SAVESPTR(PL_linestr);
285 SAVEPPTR(PL_lex_brackstack);
286 SAVEPPTR(PL_lex_casestack);
287 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
288 SAVESPTR(PL_lex_stuff);
289 SAVEI32(PL_lex_defer);
290 SAVESPTR(PL_lex_repl);
291 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
292 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
294 PL_lex_state = LEX_NORMAL;
298 PL_lex_fakebrack = 0;
299 New(899, PL_lex_brackstack, 120, char);
300 New(899, PL_lex_casestack, 12, char);
301 SAVEFREEPV(PL_lex_brackstack);
302 SAVEFREEPV(PL_lex_casestack);
304 *PL_lex_casestack = '\0';
307 PL_lex_stuff = Nullsv;
308 PL_lex_repl = Nullsv;
312 if (SvREADONLY(PL_linestr))
313 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
314 s = SvPV(PL_linestr, len);
315 if (len && s[len-1] != ';') {
316 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
317 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
318 sv_catpvn(PL_linestr, "\n;", 2);
320 SvTEMP_off(PL_linestr);
321 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
322 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
324 PL_rs = newSVpv("\n", 1);
331 PL_doextract = FALSE;
335 restore_rsfp(void *f)
337 PerlIO *fp = (PerlIO*)f;
339 if (PL_rsfp == PerlIO_stdin())
340 PerlIO_clearerr(PL_rsfp);
341 else if (PL_rsfp && (PL_rsfp != fp))
342 PerlIO_close(PL_rsfp);
347 restore_expect(void *e)
349 /* a safe way to store a small integer in a pointer */
350 PL_expect = (expectation)((char *)e - PL_tokenbuf);
354 restore_lex_expect(void *e)
356 /* a safe way to store a small integer in a pointer */
357 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
369 PL_curcop->cop_line++;
372 while (*s == ' ' || *s == '\t') s++;
373 if (strnEQ(s, "line ", 5)) {
382 while (*s == ' ' || *s == '\t')
384 if (*s == '"' && (t = strchr(s+1, '"')))
388 return; /* false alarm */
389 for (t = s; !isSPACE(*t); t++) ;
394 PL_curcop->cop_filegv = gv_fetchfile(s);
396 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
398 PL_curcop->cop_line = atoi(n)-1;
402 skipspace(register char *s)
405 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
406 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
412 while (s < PL_bufend && isSPACE(*s))
414 if (s < PL_bufend && *s == '#') {
415 while (s < PL_bufend && *s != '\n')
420 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
422 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
423 if (PL_minus_n || PL_minus_p) {
424 sv_setpv(PL_linestr,PL_minus_p ?
425 ";}continue{print or die qq(-p destination: $!\\n)" :
427 sv_catpv(PL_linestr,";}");
428 PL_minus_n = PL_minus_p = 0;
431 sv_setpv(PL_linestr,";");
432 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
433 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
434 if (PL_preprocess && !PL_in_eval)
435 (void)PerlProc_pclose(PL_rsfp);
436 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
437 PerlIO_clearerr(PL_rsfp);
439 (void)PerlIO_close(PL_rsfp);
443 PL_linestart = PL_bufptr = s + prevlen;
444 PL_bufend = s + SvCUR(PL_linestr);
447 if (PERLDB_LINE && PL_curstash != PL_debstash) {
448 SV *sv = NEWSV(85,0);
450 sv_upgrade(sv, SVt_PVMG);
451 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
452 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
463 if (PL_oldoldbufptr != PL_last_uni)
465 while (isSPACE(*PL_last_uni))
467 for (s = PL_last_uni; isALNUM(*s) || *s == '-'; s++) ;
468 if ((t = strchr(s, '(')) && t < PL_bufptr)
472 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
479 #define UNI(f) return uni(f,s)
487 PL_last_uni = PL_oldbufptr;
498 #endif /* CRIPPLED_CC */
500 #define LOP(f,x) return lop(f,x,s)
503 lop(I32 f, expectation x, char *s)
510 PL_last_lop = PL_oldbufptr;
526 PL_nexttype[PL_nexttoke] = type;
528 if (PL_lex_state != LEX_KNOWNEXT) {
529 PL_lex_defer = PL_lex_state;
530 PL_lex_expect = PL_expect;
531 PL_lex_state = LEX_KNOWNEXT;
536 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
541 start = skipspace(start);
544 (allow_pack && *s == ':') ||
545 (allow_initial_tick && *s == '\'') )
547 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
548 if (check_keyword && keyword(PL_tokenbuf, len))
550 if (token == METHOD) {
555 PL_expect = XOPERATOR;
560 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
561 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
568 force_ident(register char *s, int kind)
571 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
572 PL_nextval[PL_nexttoke].opval = o;
575 dTHR; /* just for in_eval */
576 o->op_private = OPpCONST_ENTERED;
577 /* XXX see note in pp_entereval() for why we forgo typo
578 warnings if the symbol must be introduced in an eval.
580 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
581 kind == '$' ? SVt_PV :
582 kind == '@' ? SVt_PVAV :
583 kind == '%' ? SVt_PVHV :
591 force_version(char *s)
593 OP *version = Nullop;
597 /* default VERSION number -- GBARR */
602 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
603 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
605 /* real VERSION number -- GBARR */
606 version = yylval.opval;
610 /* NOTE: The parser sees the package name and the VERSION swapped */
611 PL_nextval[PL_nexttoke].opval = version;
629 s = SvPV_force(sv, len);
633 while (s < send && *s != '\\')
638 if ( PL_hints & HINT_NEW_STRING )
639 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
642 if (s + 1 < send && (s[1] == '\\'))
643 s++; /* all that, just for this */
648 SvCUR_set(sv, d - SvPVX(sv));
650 if ( PL_hints & HINT_NEW_STRING )
651 return new_constant(NULL, 0, "q", sv, pv, "q");
658 register I32 op_type = yylval.ival;
660 if (op_type == OP_NULL) {
661 yylval.opval = PL_lex_op;
665 if (op_type == OP_CONST || op_type == OP_READLINE) {
666 SV *sv = tokeq(PL_lex_stuff);
668 if (SvTYPE(sv) == SVt_PVIV) {
669 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
675 nsv = newSVpv(p, len);
679 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
680 PL_lex_stuff = Nullsv;
684 PL_sublex_info.super_state = PL_lex_state;
685 PL_sublex_info.sub_inwhat = op_type;
686 PL_sublex_info.sub_op = PL_lex_op;
687 PL_lex_state = LEX_INTERPPUSH;
691 yylval.opval = PL_lex_op;
705 PL_lex_state = PL_sublex_info.super_state;
706 SAVEI32(PL_lex_dojoin);
707 SAVEI32(PL_lex_brackets);
708 SAVEI32(PL_lex_fakebrack);
709 SAVEI32(PL_lex_casemods);
710 SAVEI32(PL_lex_starts);
711 SAVEI32(PL_lex_state);
712 SAVESPTR(PL_lex_inpat);
713 SAVEI32(PL_lex_inwhat);
714 SAVEI16(PL_curcop->cop_line);
716 SAVEPPTR(PL_oldbufptr);
717 SAVEPPTR(PL_oldoldbufptr);
718 SAVEPPTR(PL_linestart);
719 SAVESPTR(PL_linestr);
720 SAVEPPTR(PL_lex_brackstack);
721 SAVEPPTR(PL_lex_casestack);
723 PL_linestr = PL_lex_stuff;
724 PL_lex_stuff = Nullsv;
726 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
727 PL_bufend += SvCUR(PL_linestr);
728 SAVEFREESV(PL_linestr);
730 PL_lex_dojoin = FALSE;
732 PL_lex_fakebrack = 0;
733 New(899, PL_lex_brackstack, 120, char);
734 New(899, PL_lex_casestack, 12, char);
735 SAVEFREEPV(PL_lex_brackstack);
736 SAVEFREEPV(PL_lex_casestack);
738 *PL_lex_casestack = '\0';
740 PL_lex_state = LEX_INTERPCONCAT;
741 PL_curcop->cop_line = PL_multi_start;
743 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
744 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
745 PL_lex_inpat = PL_sublex_info.sub_op;
747 PL_lex_inpat = Nullop;
755 if (!PL_lex_starts++) {
756 PL_expect = XOPERATOR;
757 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
761 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
762 PL_lex_state = LEX_INTERPCASEMOD;
766 /* Is there a right-hand side to take care of? */
767 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
768 PL_linestr = PL_lex_repl;
770 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
771 PL_bufend += SvCUR(PL_linestr);
772 SAVEFREESV(PL_linestr);
773 PL_lex_dojoin = FALSE;
775 PL_lex_fakebrack = 0;
777 *PL_lex_casestack = '\0';
779 if (SvCOMPILED(PL_lex_repl)) {
780 PL_lex_state = LEX_INTERPNORMAL;
784 PL_lex_state = LEX_INTERPCONCAT;
785 PL_lex_repl = Nullsv;
790 PL_bufend = SvPVX(PL_linestr);
791 PL_bufend += SvCUR(PL_linestr);
792 PL_expect = XOPERATOR;
800 Extracts a pattern, double-quoted string, or transliteration. This
803 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
804 processing a pattern (PL_lex_inpat is true), a transliteration
805 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
807 Returns a pointer to the character scanned up to. Iff this is
808 advanced from the start pointer supplied (ie if anything was
809 successfully parsed), will leave an OP for the substring scanned
810 in yylval. Caller must intuit reason for not parsing further
811 by looking at the next characters herself.
815 double-quoted style: \r and \n
816 regexp special ones: \D \s
818 backrefs: \1 (deprecated in substitution replacements)
819 case and quoting: \U \Q \E
820 stops on @ and $, but not for $ as tail anchor
823 characters are VERY literal, except for - not at the start or end
824 of the string, which indicates a range. scan_const expands the
825 range to the full set of intermediate characters.
827 In double-quoted strings:
829 double-quoted style: \r and \n
831 backrefs: \1 (deprecated)
832 case and quoting: \U \Q \E
835 scan_const does *not* construct ops to handle interpolated strings.
836 It stops processing as soon as it finds an embedded $ or @ variable
837 and leaves it to the caller to work out what's going on.
839 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
841 $ in pattern could be $foo or could be tail anchor. Assumption:
842 it's a tail anchor if $ is the last thing in the string, or if it's
843 followed by one of ")| \n\t"
845 \1 (backreferences) are turned into $1
847 The structure of the code is
848 while (there's a character to process) {
849 handle transliteration ranges
851 skip # initiated comments in //x patterns
852 check for embedded @foo
853 check for embedded scalars
855 leave intact backslashes from leave (below)
856 deprecate \1 in strings and sub replacements
857 handle string-changing backslashes \l \U \Q \E, etc.
858 switch (what was escaped) {
859 handle - in a transliteration (becomes a literal -)
860 handle \132 octal characters
861 handle 0x15 hex characters
862 handle \cV (control V)
863 handle printf backslashes (\f, \r, \n, etc)
866 } (end while character to read)
871 scan_const(char *start)
873 register char *send = PL_bufend; /* end of the constant */
874 SV *sv = NEWSV(93, send - start); /* sv for the constant */
875 register char *s = start; /* start of the constant */
876 register char *d = SvPVX(sv); /* destination for copies */
877 bool dorange = FALSE; /* are we in a translit range? */
879 I32 utf = PL_lex_inwhat == OP_TRANS
880 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
882 I32 thisutf = PL_lex_inwhat == OP_TRANS
883 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
886 /* leaveit is the set of acceptably-backslashed characters */
889 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
892 while (s < send || dorange) {
893 /* get transliterations out of the way (they're most literal) */
894 if (PL_lex_inwhat == OP_TRANS) {
895 /* expand a range A-Z to the full set of characters. AIE! */
897 I32 i; /* current expanded character */
898 I32 max; /* last character in range */
900 i = d - SvPVX(sv); /* remember current offset */
901 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
902 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
903 d -= 2; /* eat the first char and the - */
905 max = (U8)d[1]; /* last char in range */
907 for (i = (U8)*d; i <= max; i++)
910 /* mark the range as done, and continue */
915 /* range begins (ignore - as first or last char) */
916 else if (*s == '-' && s+1 < send && s != start) {
918 *d++ = 0xff; /* use illegal utf8 byte--see pmtrans */
927 /* if we get here, we're not doing a transliteration */
929 /* skip for regexp comments /(?#comment)/ */
930 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
932 while (s < send && *s != ')')
934 } else if (s[2] == '{') { /* This should march regcomp.c */
936 char *regparse = s + 3;
939 while (count && (c = *regparse)) {
940 if (c == '\\' && regparse[1])
948 if (*regparse == ')')
951 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
952 while (s < regparse && *s != ')')
957 /* likewise skip #-initiated comments in //x patterns */
958 else if (*s == '#' && PL_lex_inpat &&
959 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
960 while (s+1 < send && *s != '\n')
964 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
965 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
968 /* check for embedded scalars. only stop if we're sure it's a
971 else if (*s == '$') {
972 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
974 if (s + 1 < send && !strchr("()| \n\t", s[1]))
975 break; /* in regexp, $ might be tail anchor */
978 /* (now in tr/// code again) */
980 if (*s & 0x80 && dowarn && thisutf) {
981 (void)utf8_to_uv(s, &len); /* could cvt latin-1 to utf8 here... */
990 if (*s == '\\' && s+1 < send) {
993 /* some backslashes we leave behind */
994 if (*s && strchr(leaveit, *s)) {
1000 /* deprecate \1 in strings and substitution replacements */
1001 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1002 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1005 warn("\\%c better written as $%c", *s, *s);
1010 /* string-change backslash escapes */
1011 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1016 /* if we get here, it's either a quoted -, or a digit */
1019 /* quoted - in transliterations */
1021 if (PL_lex_inwhat == OP_TRANS) {
1026 /* default action is to copy the quoted character */
1031 /* \132 indicates an octal constant */
1032 case '0': case '1': case '2': case '3':
1033 case '4': case '5': case '6': case '7':
1034 *d++ = scan_oct(s, 3, &len);
1038 /* \x24 indicates a hex constant */
1042 char* e = strchr(s, '}');
1045 yyerror("Missing right brace on \\x{}");
1047 warn("Use of \\x{} without utf8 declaration");
1048 /* note: utf always shorter than hex */
1049 d = uv_to_utf8(d, scan_hex(s + 1, e - s, &len));
1054 UV uv = (UV)scan_hex(s, 2, &len);
1055 if (utf && PL_lex_inwhat == OP_TRANS &&
1056 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1058 d = uv_to_utf8(d, uv); /* doing a CU or UC */
1061 if (dowarn && uv >= 127 && UTF)
1063 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1071 /* \c is a control character */
1078 /* printf-style backslashes, formfeeds, newlines, etc */
1104 } /* end if (backslash) */
1107 } /* while loop to process each character */
1109 /* terminate the string and set up the sv */
1111 SvCUR_set(sv, d - SvPVX(sv));
1114 /* shrink the sv if we allocated more than we used */
1115 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1116 SvLEN_set(sv, SvCUR(sv) + 1);
1117 Renew(SvPVX(sv), SvLEN(sv), char);
1120 /* return the substring (via yylval) only if we parsed anything */
1121 if (s > PL_bufptr) {
1122 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1123 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1125 ( PL_lex_inwhat == OP_TRANS
1127 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1130 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1136 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1138 intuit_more(register char *s)
1140 if (PL_lex_brackets)
1142 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1144 if (*s != '{' && *s != '[')
1149 /* In a pattern, so maybe we have {n,m}. */
1166 /* On the other hand, maybe we have a character class */
1169 if (*s == ']' || *s == '^')
1172 int weight = 2; /* let's weigh the evidence */
1174 unsigned char un_char = 255, last_un_char;
1175 char *send = strchr(s,']');
1176 char tmpbuf[sizeof PL_tokenbuf * 4];
1178 if (!send) /* has to be an expression */
1181 Zero(seen,256,char);
1184 else if (isDIGIT(*s)) {
1186 if (isDIGIT(s[1]) && s[2] == ']')
1192 for (; s < send; s++) {
1193 last_un_char = un_char;
1194 un_char = (unsigned char)*s;
1199 weight -= seen[un_char] * 10;
1200 if (isALNUM(s[1])) {
1201 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1202 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1207 else if (*s == '$' && s[1] &&
1208 strchr("[#!%*<>()-=",s[1])) {
1209 if (/*{*/ strchr("])} =",s[2]))
1218 if (strchr("wds]",s[1]))
1220 else if (seen['\''] || seen['"'])
1222 else if (strchr("rnftbxcav",s[1]))
1224 else if (isDIGIT(s[1])) {
1226 while (s[1] && isDIGIT(s[1]))
1236 if (strchr("aA01! ",last_un_char))
1238 if (strchr("zZ79~",s[1]))
1240 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1241 weight -= 5; /* cope with negative subscript */
1244 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1245 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1250 if (keyword(tmpbuf, d - tmpbuf))
1253 if (un_char == last_un_char + 1)
1255 weight -= seen[un_char];
1260 if (weight >= 0) /* probably a character class */
1268 intuit_method(char *start, GV *gv)
1270 char *s = start + (*start == '$');
1271 char tmpbuf[sizeof PL_tokenbuf];
1279 if ((cv = GvCVu(gv))) {
1280 char *proto = SvPVX(cv);
1290 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1291 if (*start == '$') {
1292 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1297 return *s == '(' ? FUNCMETH : METHOD;
1299 if (!keyword(tmpbuf, len)) {
1300 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1305 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1306 if (indirgv && GvCVu(indirgv))
1308 /* filehandle or package name makes it a method */
1309 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1311 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1312 return 0; /* no assumptions -- "=>" quotes bearword */
1314 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1316 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1320 return *s == '(' ? FUNCMETH : METHOD;
1330 char *pdb = PerlEnv_getenv("PERL5DB");
1334 SETERRNO(0,SS$_NORMAL);
1335 return "BEGIN { require 'perl5db.pl' }";
1341 /* Encoded script support. filter_add() effectively inserts a
1342 * 'pre-processing' function into the current source input stream.
1343 * Note that the filter function only applies to the current source file
1344 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1346 * The datasv parameter (which may be NULL) can be used to pass
1347 * private data to this instance of the filter. The filter function
1348 * can recover the SV using the FILTER_DATA macro and use it to
1349 * store private buffers and state information.
1351 * The supplied datasv parameter is upgraded to a PVIO type
1352 * and the IoDIRP field is used to store the function pointer.
1353 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1354 * private use must be set using malloc'd pointers.
1356 static int filter_debug = 0;
1359 filter_add(filter_t funcp, SV *datasv)
1361 if (!funcp){ /* temporary handy debugging hack to be deleted */
1362 filter_debug = atoi((char*)datasv);
1365 if (!PL_rsfp_filters)
1366 PL_rsfp_filters = newAV();
1368 datasv = NEWSV(255,0);
1369 if (!SvUPGRADE(datasv, SVt_PVIO))
1370 die("Can't upgrade filter_add data to SVt_PVIO");
1371 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1373 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1374 av_unshift(PL_rsfp_filters, 1);
1375 av_store(PL_rsfp_filters, 0, datasv) ;
1380 /* Delete most recently added instance of this filter function. */
1382 filter_del(filter_t funcp)
1385 warn("filter_del func %p", funcp);
1386 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1388 /* if filter is on top of stack (usual case) just pop it off */
1389 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (void*)funcp){
1390 sv_free(av_pop(PL_rsfp_filters));
1394 /* we need to search for the correct entry and clear it */
1395 die("filter_del can only delete in reverse order (currently)");
1399 /* Invoke the n'th filter function for the current rsfp. */
1401 filter_read(int idx, SV *buf_sv, int maxlen)
1404 /* 0 = read one text line */
1409 if (!PL_rsfp_filters)
1411 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1412 /* Provide a default input filter to make life easy. */
1413 /* Note that we append to the line. This is handy. */
1415 warn("filter_read %d: from rsfp\n", idx);
1419 int old_len = SvCUR(buf_sv) ;
1421 /* ensure buf_sv is large enough */
1422 SvGROW(buf_sv, old_len + maxlen) ;
1423 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1424 if (PerlIO_error(PL_rsfp))
1425 return -1; /* error */
1427 return 0 ; /* end of file */
1429 SvCUR_set(buf_sv, old_len + len) ;
1432 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1433 if (PerlIO_error(PL_rsfp))
1434 return -1; /* error */
1436 return 0 ; /* end of file */
1439 return SvCUR(buf_sv);
1441 /* Skip this filter slot if filter has been deleted */
1442 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1444 warn("filter_read %d: skipped (filter deleted)\n", idx);
1445 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1447 /* Get function pointer hidden within datasv */
1448 funcp = (filter_t)IoDIRP(datasv);
1450 warn("filter_read %d: via function %p (%s)\n",
1451 idx, funcp, SvPV(datasv,PL_na));
1452 /* Call function. The function is expected to */
1453 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1454 /* Return: <0:error, =0:eof, >0:not eof */
1455 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1459 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1462 if (!PL_rsfp_filters) {
1463 filter_add(win32_textfilter,NULL);
1466 if (PL_rsfp_filters) {
1469 SvCUR_set(sv, 0); /* start with empty line */
1470 if (FILTER_READ(0, sv, 0) > 0)
1471 return ( SvPVX(sv) ) ;
1476 return (sv_gets(sv, fp, append));
1481 static char* exp_name[] =
1482 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1485 EXT int yychar; /* last token */
1490 Works out what to call the token just pulled out of the input
1491 stream. The yacc parser takes care of taking the ops we return and
1492 stitching them into a tree.
1498 if read an identifier
1499 if we're in a my declaration
1500 croak if they tried to say my($foo::bar)
1501 build the ops for a my() declaration
1502 if it's an access to a my() variable
1503 are we in a sort block?
1504 croak if my($a); $a <=> $b
1505 build ops for access to a my() variable
1506 if in a dq string, and they've said @foo and we can't find @foo
1508 build ops for a bareword
1509 if we already built the token before, use it.
1523 /* check if there's an identifier for us to look at */
1524 if (PL_pending_ident) {
1525 /* pit holds the identifier we read and pending_ident is reset */
1526 char pit = PL_pending_ident;
1527 PL_pending_ident = 0;
1529 /* if we're in a my(), we can't allow dynamics here.
1530 $foo'bar has already been turned into $foo::bar, so
1531 just check for colons.
1533 if it's a legal name, the OP is a PADANY.
1536 if (strchr(PL_tokenbuf,':'))
1537 croak(no_myglob,PL_tokenbuf);
1539 yylval.opval = newOP(OP_PADANY, 0);
1540 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1545 build the ops for accesses to a my() variable.
1547 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1548 then used in a comparison. This catches most, but not
1549 all cases. For instance, it catches
1550 sort { my($a); $a <=> $b }
1552 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1553 (although why you'd do that is anyone's guess).
1556 if (!strchr(PL_tokenbuf,':')) {
1558 /* Check for single character per-thread SVs */
1559 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1560 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1561 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1563 yylval.opval = newOP(OP_THREADSV, 0);
1564 yylval.opval->op_targ = tmp;
1567 #endif /* USE_THREADS */
1568 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1569 /* if it's a sort block and they're naming $a or $b */
1570 if (PL_last_lop_op == OP_SORT &&
1571 PL_tokenbuf[0] == '$' &&
1572 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1575 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1576 d < PL_bufend && *d != '\n';
1579 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1580 croak("Can't use \"my %s\" in sort comparison",
1586 yylval.opval = newOP(OP_PADANY, 0);
1587 yylval.opval->op_targ = tmp;
1593 Whine if they've said @foo in a doublequoted string,
1594 and @foo isn't a variable we can find in the symbol
1597 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1598 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1599 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1600 yyerror(form("In string, %s now must be written as \\%s",
1601 PL_tokenbuf, PL_tokenbuf));
1604 /* build ops for a bareword */
1605 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1606 yylval.opval->op_private = OPpCONST_ENTERED;
1607 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1608 ((PL_tokenbuf[0] == '$') ? SVt_PV
1609 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1614 /* no identifier pending identification */
1616 switch (PL_lex_state) {
1618 case LEX_NORMAL: /* Some compilers will produce faster */
1619 case LEX_INTERPNORMAL: /* code if we comment these out. */
1623 /* when we're already built the next token, just pull it out the queue */
1626 yylval = PL_nextval[PL_nexttoke];
1628 PL_lex_state = PL_lex_defer;
1629 PL_expect = PL_lex_expect;
1630 PL_lex_defer = LEX_NORMAL;
1632 return(PL_nexttype[PL_nexttoke]);
1634 /* interpolated case modifiers like \L \U, including \Q and \E.
1635 when we get here, PL_bufptr is at the \
1637 case LEX_INTERPCASEMOD:
1639 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1640 croak("panic: INTERPCASEMOD");
1642 /* handle \E or end of string */
1643 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1647 if (PL_lex_casemods) {
1648 oldmod = PL_lex_casestack[--PL_lex_casemods];
1649 PL_lex_casestack[PL_lex_casemods] = '\0';
1651 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1653 PL_lex_state = LEX_INTERPCONCAT;
1657 if (PL_bufptr != PL_bufend)
1659 PL_lex_state = LEX_INTERPCONCAT;
1664 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1665 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1666 if (strchr("LU", *s) &&
1667 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1669 PL_lex_casestack[--PL_lex_casemods] = '\0';
1672 if (PL_lex_casemods > 10) {
1673 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1674 if (newlb != PL_lex_casestack) {
1676 PL_lex_casestack = newlb;
1679 PL_lex_casestack[PL_lex_casemods++] = *s;
1680 PL_lex_casestack[PL_lex_casemods] = '\0';
1681 PL_lex_state = LEX_INTERPCONCAT;
1682 PL_nextval[PL_nexttoke].ival = 0;
1685 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1687 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1689 PL_nextval[PL_nexttoke].ival = OP_LC;
1691 PL_nextval[PL_nexttoke].ival = OP_UC;
1693 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1695 croak("panic: yylex");
1698 if (PL_lex_starts) {
1707 case LEX_INTERPPUSH:
1708 return sublex_push();
1710 case LEX_INTERPSTART:
1711 if (PL_bufptr == PL_bufend)
1712 return sublex_done();
1714 PL_lex_dojoin = (*PL_bufptr == '@');
1715 PL_lex_state = LEX_INTERPNORMAL;
1716 if (PL_lex_dojoin) {
1717 PL_nextval[PL_nexttoke].ival = 0;
1720 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1721 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1722 force_next(PRIVATEREF);
1724 force_ident("\"", '$');
1725 #endif /* USE_THREADS */
1726 PL_nextval[PL_nexttoke].ival = 0;
1728 PL_nextval[PL_nexttoke].ival = 0;
1730 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1733 if (PL_lex_starts++) {
1739 case LEX_INTERPENDMAYBE:
1740 if (intuit_more(PL_bufptr)) {
1741 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1747 if (PL_lex_dojoin) {
1748 PL_lex_dojoin = FALSE;
1749 PL_lex_state = LEX_INTERPCONCAT;
1753 case LEX_INTERPCONCAT:
1755 if (PL_lex_brackets)
1756 croak("panic: INTERPCONCAT");
1758 if (PL_bufptr == PL_bufend)
1759 return sublex_done();
1761 if (SvIVX(PL_linestr) == '\'') {
1762 SV *sv = newSVsv(PL_linestr);
1765 else if ( PL_hints & HINT_NEW_RE )
1766 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1767 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1771 s = scan_const(PL_bufptr);
1773 PL_lex_state = LEX_INTERPCASEMOD;
1775 PL_lex_state = LEX_INTERPSTART;
1778 if (s != PL_bufptr) {
1779 PL_nextval[PL_nexttoke] = yylval;
1782 if (PL_lex_starts++)
1792 PL_lex_state = LEX_NORMAL;
1793 s = scan_formline(PL_bufptr);
1794 if (!PL_lex_formbrack)
1800 PL_oldoldbufptr = PL_oldbufptr;
1803 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1810 * Note: we try to be careful never to call the isXXX_utf8() functions unless we're
1811 * pretty sure we've seen the beginning of a UTF-8 character (that is, the two high
1812 * bits are set). Otherwise we risk loading in the heavy-duty SWASHINIT and SWASHGET
1813 * routines unnecessarily. You will see this not just here but throughout this file.
1815 if (UTF && (*s & 0xc0) == 0x80) {
1816 if (isIDFIRST_utf8(s))
1819 croak("Unrecognized character \\x%02X", *s & 255);
1822 goto fake_eof; /* emulate EOF on ^D or ^Z */
1827 if (PL_lex_brackets)
1828 yyerror("Missing right bracket");
1831 if (s++ < PL_bufend)
1832 goto retry; /* ignore stray nulls */
1835 if (!PL_in_eval && !PL_preambled) {
1836 PL_preambled = TRUE;
1837 sv_setpv(PL_linestr,incl_perldb());
1838 if (SvCUR(PL_linestr))
1839 sv_catpv(PL_linestr,";");
1841 while(AvFILLp(PL_preambleav) >= 0) {
1842 SV *tmpsv = av_shift(PL_preambleav);
1843 sv_catsv(PL_linestr, tmpsv);
1844 sv_catpv(PL_linestr, ";");
1847 sv_free((SV*)PL_preambleav);
1848 PL_preambleav = NULL;
1850 if (PL_minus_n || PL_minus_p) {
1851 sv_catpv(PL_linestr, "LINE: while (<>) {");
1853 sv_catpv(PL_linestr,"chomp;");
1855 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1857 GvIMPORTED_AV_on(gv);
1859 if (strchr("/'\"", *PL_splitstr)
1860 && strchr(PL_splitstr + 1, *PL_splitstr))
1861 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1864 s = "'~#\200\1'"; /* surely one char is unused...*/
1865 while (s[1] && strchr(PL_splitstr, *s)) s++;
1867 sv_catpvf(PL_linestr, "@F=split(%s%c",
1868 "q" + (delim == '\''), delim);
1869 for (s = PL_splitstr; *s; s++) {
1871 sv_catpvn(PL_linestr, "\\", 1);
1872 sv_catpvn(PL_linestr, s, 1);
1874 sv_catpvf(PL_linestr, "%c);", delim);
1878 sv_catpv(PL_linestr,"@F=split(' ');");
1881 sv_catpv(PL_linestr, "\n");
1882 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1883 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1884 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1885 SV *sv = NEWSV(85,0);
1887 sv_upgrade(sv, SVt_PVMG);
1888 sv_setsv(sv,PL_linestr);
1889 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1894 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1897 if (PL_preprocess && !PL_in_eval)
1898 (void)PerlProc_pclose(PL_rsfp);
1899 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1900 PerlIO_clearerr(PL_rsfp);
1902 (void)PerlIO_close(PL_rsfp);
1905 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1906 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1907 sv_catpv(PL_linestr,";}");
1908 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1909 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1910 PL_minus_n = PL_minus_p = 0;
1913 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1914 sv_setpv(PL_linestr,"");
1915 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1918 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1919 PL_doextract = FALSE;
1921 /* Incest with pod. */
1922 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1923 sv_setpv(PL_linestr, "");
1924 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1925 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1926 PL_doextract = FALSE;
1930 } while (PL_doextract);
1931 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1932 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1933 SV *sv = NEWSV(85,0);
1935 sv_upgrade(sv, SVt_PVMG);
1936 sv_setsv(sv,PL_linestr);
1937 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1939 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1940 if (PL_curcop->cop_line == 1) {
1941 while (s < PL_bufend && isSPACE(*s))
1943 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1947 if (*s == '#' && *(s+1) == '!')
1949 #ifdef ALTERNATE_SHEBANG
1951 static char as[] = ALTERNATE_SHEBANG;
1952 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1953 d = s + (sizeof(as) - 1);
1955 #endif /* ALTERNATE_SHEBANG */
1964 while (*d && !isSPACE(*d))
1968 #ifdef ARG_ZERO_IS_SCRIPT
1969 if (ipathend > ipath) {
1971 * HP-UX (at least) sets argv[0] to the script name,
1972 * which makes $^X incorrect. And Digital UNIX and Linux,
1973 * at least, set argv[0] to the basename of the Perl
1974 * interpreter. So, having found "#!", we'll set it right.
1976 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
1977 assert(SvPOK(x) || SvGMAGICAL(x));
1978 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
1979 sv_setpvn(x, ipath, ipathend - ipath);
1982 TAINT_NOT; /* $^X is always tainted, but that's OK */
1984 #endif /* ARG_ZERO_IS_SCRIPT */
1989 d = instr(s,"perl -");
1991 d = instr(s,"perl");
1992 #ifdef ALTERNATE_SHEBANG
1994 * If the ALTERNATE_SHEBANG on this system starts with a
1995 * character that can be part of a Perl expression, then if
1996 * we see it but not "perl", we're probably looking at the
1997 * start of Perl code, not a request to hand off to some
1998 * other interpreter. Similarly, if "perl" is there, but
1999 * not in the first 'word' of the line, we assume the line
2000 * contains the start of the Perl program.
2002 if (d && *s != '#') {
2004 while (*c && !strchr("; \t\r\n\f\v#", *c))
2007 d = Nullch; /* "perl" not in first word; ignore */
2009 *s = '#'; /* Don't try to parse shebang line */
2011 #endif /* ALTERNATE_SHEBANG */
2016 !instr(s,"indir") &&
2017 instr(PL_origargv[0],"perl"))
2023 while (s < PL_bufend && isSPACE(*s))
2025 if (s < PL_bufend) {
2026 Newz(899,newargv,PL_origargc+3,char*);
2028 while (s < PL_bufend && !isSPACE(*s))
2031 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2034 newargv = PL_origargv;
2036 execv(ipath, newargv);
2037 croak("Can't exec %s", ipath);
2040 U32 oldpdb = PL_perldb;
2041 bool oldn = PL_minus_n;
2042 bool oldp = PL_minus_p;
2044 while (*d && !isSPACE(*d)) d++;
2045 while (*d == ' ' || *d == '\t') d++;
2049 if (*d == 'M' || *d == 'm') {
2051 while (*d && !isSPACE(*d)) d++;
2052 croak("Too late for \"-%.*s\" option",
2055 d = moreswitches(d);
2057 if (PERLDB_LINE && !oldpdb ||
2058 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2059 /* if we have already added "LINE: while (<>) {",
2060 we must not do it again */
2062 sv_setpv(PL_linestr, "");
2063 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2064 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2065 PL_preambled = FALSE;
2067 (void)gv_fetchfile(PL_origfilename);
2074 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2076 PL_lex_state = LEX_FORMLINE;
2081 #ifndef TMP_CRLF_PATCH
2082 warn("Illegal character \\%03o (carriage return)", '\r');
2084 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2086 case ' ': case '\t': case '\f': case 013:
2091 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2093 while (s < d && *s != '\n')
2098 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2100 PL_lex_state = LEX_FORMLINE;
2110 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2115 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2118 if (strnEQ(s,"=>",2)) {
2119 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2120 OPERATOR('-'); /* unary minus */
2122 PL_last_uni = PL_oldbufptr;
2123 PL_last_lop_op = OP_FTEREAD; /* good enough */
2125 case 'r': FTST(OP_FTEREAD);
2126 case 'w': FTST(OP_FTEWRITE);
2127 case 'x': FTST(OP_FTEEXEC);
2128 case 'o': FTST(OP_FTEOWNED);
2129 case 'R': FTST(OP_FTRREAD);
2130 case 'W': FTST(OP_FTRWRITE);
2131 case 'X': FTST(OP_FTREXEC);
2132 case 'O': FTST(OP_FTROWNED);
2133 case 'e': FTST(OP_FTIS);
2134 case 'z': FTST(OP_FTZERO);
2135 case 's': FTST(OP_FTSIZE);
2136 case 'f': FTST(OP_FTFILE);
2137 case 'd': FTST(OP_FTDIR);
2138 case 'l': FTST(OP_FTLINK);
2139 case 'p': FTST(OP_FTPIPE);
2140 case 'S': FTST(OP_FTSOCK);
2141 case 'u': FTST(OP_FTSUID);
2142 case 'g': FTST(OP_FTSGID);
2143 case 'k': FTST(OP_FTSVTX);
2144 case 'b': FTST(OP_FTBLK);
2145 case 'c': FTST(OP_FTCHR);
2146 case 't': FTST(OP_FTTTY);
2147 case 'T': FTST(OP_FTTEXT);
2148 case 'B': FTST(OP_FTBINARY);
2149 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2150 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2151 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2153 croak("Unrecognized file test: -%c", (int)tmp);
2160 if (PL_expect == XOPERATOR)
2165 else if (*s == '>') {
2168 if (isIDFIRST(*s)) {
2169 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2177 if (PL_expect == XOPERATOR)
2180 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2182 OPERATOR('-'); /* unary minus */
2189 if (PL_expect == XOPERATOR)
2194 if (PL_expect == XOPERATOR)
2197 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2203 if (PL_expect != XOPERATOR) {
2204 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2205 PL_expect = XOPERATOR;
2206 force_ident(PL_tokenbuf, '*');
2219 if (PL_expect == XOPERATOR) {
2223 PL_tokenbuf[0] = '%';
2224 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2225 if (!PL_tokenbuf[1]) {
2227 yyerror("Final % should be \\% or %name");
2230 PL_pending_ident = '%';
2252 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2253 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2258 if (PL_curcop->cop_line < PL_copline)
2259 PL_copline = PL_curcop->cop_line;
2270 if (PL_lex_brackets <= 0)
2271 yyerror("Unmatched right bracket");
2274 if (PL_lex_state == LEX_INTERPNORMAL) {
2275 if (PL_lex_brackets == 0) {
2276 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2277 PL_lex_state = LEX_INTERPEND;
2284 if (PL_lex_brackets > 100) {
2285 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2286 if (newlb != PL_lex_brackstack) {
2288 PL_lex_brackstack = newlb;
2291 switch (PL_expect) {
2293 if (PL_lex_formbrack) {
2297 if (PL_oldoldbufptr == PL_last_lop)
2298 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2300 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2301 OPERATOR(HASHBRACK);
2303 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2306 PL_tokenbuf[0] = '\0';
2307 if (d < PL_bufend && *d == '-') {
2308 PL_tokenbuf[0] = '-';
2310 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2313 if (d < PL_bufend && isIDFIRST(*d)) {
2314 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2316 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2319 char minus = (PL_tokenbuf[0] == '-');
2320 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2327 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2331 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2336 if (PL_oldoldbufptr == PL_last_lop)
2337 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2339 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2342 OPERATOR(HASHBRACK);
2343 /* This hack serves to disambiguate a pair of curlies
2344 * as being a block or an anon hash. Normally, expectation
2345 * determines that, but in cases where we're not in a
2346 * position to expect anything in particular (like inside
2347 * eval"") we have to resolve the ambiguity. This code
2348 * covers the case where the first term in the curlies is a
2349 * quoted string. Most other cases need to be explicitly
2350 * disambiguated by prepending a `+' before the opening
2351 * curly in order to force resolution as an anon hash.
2353 * XXX should probably propagate the outer expectation
2354 * into eval"" to rely less on this hack, but that could
2355 * potentially break current behavior of eval"".
2359 if (*s == '\'' || *s == '"' || *s == '`') {
2360 /* common case: get past first string, handling escapes */
2361 for (t++; t < PL_bufend && *t != *s;)
2362 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2366 else if (*s == 'q') {
2369 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2370 && !isALNUM(*t)))) {
2372 char open, close, term;
2375 while (t < PL_bufend && isSPACE(*t))
2379 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2383 for (t++; t < PL_bufend; t++) {
2384 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2386 else if (*t == open)
2390 for (t++; t < PL_bufend; t++) {
2391 if (*t == '\\' && t+1 < PL_bufend)
2393 else if (*t == close && --brackets <= 0)
2395 else if (*t == open)
2401 else if (isALPHA(*s)) {
2402 for (t++; t < PL_bufend && isALNUM(*t); t++) ;
2404 while (t < PL_bufend && isSPACE(*t))
2406 /* if comma follows first term, call it an anon hash */
2407 /* XXX it could be a comma expression with loop modifiers */
2408 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2409 || (*t == '=' && t[1] == '>')))
2410 OPERATOR(HASHBRACK);
2411 if (PL_expect == XREF)
2414 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2420 yylval.ival = PL_curcop->cop_line;
2421 if (isSPACE(*s) || *s == '#')
2422 PL_copline = NOLINE; /* invalidate current command line number */
2427 if (PL_lex_brackets <= 0)
2428 yyerror("Unmatched right bracket");
2430 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2431 if (PL_lex_brackets < PL_lex_formbrack)
2432 PL_lex_formbrack = 0;
2433 if (PL_lex_state == LEX_INTERPNORMAL) {
2434 if (PL_lex_brackets == 0) {
2435 if (PL_lex_fakebrack) {
2436 PL_lex_state = LEX_INTERPEND;
2438 return yylex(); /* ignore fake brackets */
2440 if (*s == '-' && s[1] == '>')
2441 PL_lex_state = LEX_INTERPENDMAYBE;
2442 else if (*s != '[' && *s != '{')
2443 PL_lex_state = LEX_INTERPEND;
2446 if (PL_lex_brackets < PL_lex_fakebrack) {
2448 PL_lex_fakebrack = 0;
2449 return yylex(); /* ignore fake brackets */
2459 if (PL_expect == XOPERATOR) {
2460 if (PL_dowarn && isALPHA(*s) && PL_bufptr == PL_linestart) {
2461 PL_curcop->cop_line--;
2463 PL_curcop->cop_line++;
2468 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2470 PL_expect = XOPERATOR;
2471 force_ident(PL_tokenbuf, '&');
2475 yylval.ival = (OPpENTERSUB_AMPER<<8);
2494 if (PL_dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2495 warn("Reversed %c= operator",(int)tmp);
2497 if (PL_expect == XSTATE && isALPHA(tmp) &&
2498 (s == PL_linestart+1 || s[-2] == '\n') )
2500 if (PL_in_eval && !PL_rsfp) {
2505 if (strnEQ(s,"=cut",4)) {
2519 PL_doextract = TRUE;
2522 if (PL_lex_brackets < PL_lex_formbrack) {
2524 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2525 if (*t == '\n' || *t == '#') {
2543 if (PL_expect != XOPERATOR) {
2544 if (s[1] != '<' && !strchr(s,'>'))
2547 s = scan_heredoc(s);
2549 s = scan_inputsymbol(s);
2550 TERM(sublex_start());
2555 SHop(OP_LEFT_SHIFT);
2569 SHop(OP_RIGHT_SHIFT);
2578 if (PL_expect == XOPERATOR) {
2579 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2582 return ','; /* grandfather non-comma-format format */
2586 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2587 if (PL_expect == XOPERATOR)
2588 no_op("Array length", PL_bufptr);
2589 PL_tokenbuf[0] = '@';
2590 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2592 if (!PL_tokenbuf[1])
2594 PL_expect = XOPERATOR;
2595 PL_pending_ident = '#';
2599 if (PL_expect == XOPERATOR)
2600 no_op("Scalar", PL_bufptr);
2601 PL_tokenbuf[0] = '$';
2602 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2603 if (!PL_tokenbuf[1]) {
2605 yyerror("Final $ should be \\$ or $name");
2609 /* This kludge not intended to be bulletproof. */
2610 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2611 yylval.opval = newSVOP(OP_CONST, 0,
2612 newSViv((IV)PL_compiling.cop_arybase));
2613 yylval.opval->op_private = OPpCONST_ARYBASE;
2618 if (PL_lex_state == LEX_NORMAL)
2621 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2624 PL_tokenbuf[0] = '@';
2627 isSPACE(*t) || isALNUM(*t) || *t == '$';
2630 PL_bufptr = skipspace(PL_bufptr);
2631 while (t < PL_bufend && *t != ']')
2633 warn("Multidimensional syntax %.*s not supported",
2634 (t - PL_bufptr) + 1, PL_bufptr);
2638 else if (*s == '{') {
2639 PL_tokenbuf[0] = '%';
2640 if (PL_dowarn && strEQ(PL_tokenbuf+1, "SIG") &&
2641 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2643 char tmpbuf[sizeof PL_tokenbuf];
2645 for (t++; isSPACE(*t); t++) ;
2646 if (isIDFIRST(*t)) {
2647 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2648 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2649 warn("You need to quote \"%s\"", tmpbuf);
2655 PL_expect = XOPERATOR;
2656 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2657 bool islop = (PL_last_lop == PL_oldoldbufptr);
2658 if (!islop || PL_last_lop_op == OP_GREPSTART)
2659 PL_expect = XOPERATOR;
2660 else if (strchr("$@\"'`q", *s))
2661 PL_expect = XTERM; /* e.g. print $fh "foo" */
2662 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2663 PL_expect = XTERM; /* e.g. print $fh &sub */
2664 else if (isIDFIRST(*s)) {
2665 char tmpbuf[sizeof PL_tokenbuf];
2666 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2667 if (tmp = keyword(tmpbuf, len)) {
2668 /* binary operators exclude handle interpretations */
2680 PL_expect = XTERM; /* e.g. print $fh length() */
2685 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2686 if (gv && GvCVu(gv))
2687 PL_expect = XTERM; /* e.g. print $fh subr() */
2690 else if (isDIGIT(*s))
2691 PL_expect = XTERM; /* e.g. print $fh 3 */
2692 else if (*s == '.' && isDIGIT(s[1]))
2693 PL_expect = XTERM; /* e.g. print $fh .3 */
2694 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2695 PL_expect = XTERM; /* e.g. print $fh -1 */
2696 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2697 PL_expect = XTERM; /* print $fh <<"EOF" */
2699 PL_pending_ident = '$';
2703 if (PL_expect == XOPERATOR)
2705 PL_tokenbuf[0] = '@';
2706 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2707 if (!PL_tokenbuf[1]) {
2709 yyerror("Final @ should be \\@ or @name");
2712 if (PL_lex_state == LEX_NORMAL)
2714 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2716 PL_tokenbuf[0] = '%';
2718 /* Warn about @ where they meant $. */
2720 if (*s == '[' || *s == '{') {
2722 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2724 if (*t == '}' || *t == ']') {
2726 PL_bufptr = skipspace(PL_bufptr);
2727 warn("Scalar value %.*s better written as $%.*s",
2728 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2733 PL_pending_ident = '@';
2736 case '/': /* may either be division or pattern */
2737 case '?': /* may either be conditional or pattern */
2738 if (PL_expect != XOPERATOR) {
2739 /* Disable warning on "study /blah/" */
2740 if (PL_oldoldbufptr == PL_last_uni
2741 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2742 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2744 s = scan_pat(s,OP_MATCH);
2745 TERM(sublex_start());
2753 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack && s[1] == '\n' &&
2754 (s == PL_linestart || s[-1] == '\n') ) {
2755 PL_lex_formbrack = 0;
2759 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2765 yylval.ival = OPf_SPECIAL;
2771 if (PL_expect != XOPERATOR)
2776 case '0': case '1': case '2': case '3': case '4':
2777 case '5': case '6': case '7': case '8': case '9':
2779 if (PL_expect == XOPERATOR)
2785 if (PL_expect == XOPERATOR) {
2786 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2789 return ','; /* grandfather non-comma-format format */
2795 missingterm((char*)0);
2796 yylval.ival = OP_CONST;
2797 TERM(sublex_start());
2801 if (PL_expect == XOPERATOR) {
2802 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2805 return ','; /* grandfather non-comma-format format */
2811 missingterm((char*)0);
2812 yylval.ival = OP_CONST;
2813 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2814 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2815 yylval.ival = OP_STRINGIFY;
2819 TERM(sublex_start());
2823 if (PL_expect == XOPERATOR)
2824 no_op("Backticks",s);
2826 missingterm((char*)0);
2827 yylval.ival = OP_BACKTICK;
2829 TERM(sublex_start());
2833 if (PL_dowarn && PL_lex_inwhat && isDIGIT(*s))
2834 warn("Can't use \\%c to mean $%c in expression", *s, *s);
2835 if (PL_expect == XOPERATOR)
2836 no_op("Backslash",s);
2840 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2879 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2881 /* Some keywords can be followed by any delimiter, including ':' */
2882 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2883 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2884 (PL_tokenbuf[0] == 'q' &&
2885 strchr("qwxr", PL_tokenbuf[1]))));
2887 /* x::* is just a word, unless x is "CORE" */
2888 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2892 while (d < PL_bufend && isSPACE(*d))
2893 d++; /* no comments skipped here, or s### is misparsed */
2895 /* Is this a label? */
2896 if (!tmp && PL_expect == XSTATE
2897 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2899 yylval.pval = savepv(PL_tokenbuf);
2904 /* Check for keywords */
2905 tmp = keyword(PL_tokenbuf, len);
2907 /* Is this a word before a => operator? */
2908 if (strnEQ(d,"=>",2)) {
2910 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2911 yylval.opval->op_private = OPpCONST_BARE;
2915 if (tmp < 0) { /* second-class keyword? */
2916 GV *ogv = Nullgv; /* override (winner) */
2917 GV *hgv = Nullgv; /* hidden (loser) */
2918 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2920 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
2923 if (GvIMPORTED_CV(gv))
2925 else if (! CvMETHOD(cv))
2929 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2930 (gv = *gvp) != (GV*)&PL_sv_undef &&
2931 GvCVu(gv) && GvIMPORTED_CV(gv))
2937 tmp = 0; /* overridden by import or by GLOBAL */
2940 && -tmp==KEY_lock /* XXX generalizable kludge */
2941 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
2943 tmp = 0; /* any sub overrides "weak" keyword */
2945 else { /* no override */
2949 if (PL_dowarn && hgv)
2950 warn("Ambiguous call resolved as CORE::%s(), %s",
2951 GvENAME(hgv), "qualify as such or use &");
2958 default: /* not a keyword */
2961 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
2963 /* Get the rest if it looks like a package qualifier */
2965 if (*s == '\'' || *s == ':' && s[1] == ':') {
2967 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
2970 croak("Bad name after %s%s", PL_tokenbuf,
2971 *s == '\'' ? "'" : "::");
2975 if (PL_expect == XOPERATOR) {
2976 if (PL_bufptr == PL_linestart) {
2977 PL_curcop->cop_line--;
2979 PL_curcop->cop_line++;
2982 no_op("Bareword",s);
2985 /* Look for a subroutine with this name in current package,
2986 unless name is "Foo::", in which case Foo is a bearword
2987 (and a package name). */
2990 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
2992 if (PL_dowarn && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
2993 warn("Bareword \"%s\" refers to nonexistent package",
2996 PL_tokenbuf[len] = '\0';
3003 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3006 /* if we saw a global override before, get the right name */
3009 sv = newSVpv("CORE::GLOBAL::",14);
3010 sv_catpv(sv,PL_tokenbuf);
3013 sv = newSVpv(PL_tokenbuf,0);
3015 /* Presume this is going to be a bareword of some sort. */
3018 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3019 yylval.opval->op_private = OPpCONST_BARE;
3021 /* And if "Foo::", then that's what it certainly is. */
3026 /* See if it's the indirect object for a list operator. */
3028 if (PL_oldoldbufptr &&
3029 PL_oldoldbufptr < PL_bufptr &&
3030 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3031 /* NO SKIPSPACE BEFORE HERE! */
3033 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3034 || (PL_last_lop_op == OP_ENTERSUB
3036 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3038 bool immediate_paren = *s == '(';
3040 /* (Now we can afford to cross potential line boundary.) */
3043 /* Two barewords in a row may indicate method call. */
3045 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
3048 /* If not a declared subroutine, it's an indirect object. */
3049 /* (But it's an indir obj regardless for sort.) */
3051 if ((PL_last_lop_op == OP_SORT ||
3052 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3053 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3054 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3059 /* If followed by a paren, it's certainly a subroutine. */
3061 PL_expect = XOPERATOR;
3065 if (gv && GvCVu(gv)) {
3066 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3067 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3072 PL_nextval[PL_nexttoke].opval = yylval.opval;
3073 PL_expect = XOPERATOR;
3079 /* If followed by var or block, call it a method (unless sub) */
3081 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3082 PL_last_lop = PL_oldbufptr;
3083 PL_last_lop_op = OP_METHOD;
3087 /* If followed by a bareword, see if it looks like indir obj. */
3089 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3092 /* Not a method, so call it a subroutine (if defined) */
3094 if (gv && GvCVu(gv)) {
3096 if (lastchar == '-')
3097 warn("Ambiguous use of -%s resolved as -&%s()",
3098 PL_tokenbuf, PL_tokenbuf);
3099 PL_last_lop = PL_oldbufptr;
3100 PL_last_lop_op = OP_ENTERSUB;
3101 /* Check for a constant sub */
3103 if ((sv = cv_const_sv(cv))) {
3105 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3106 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3107 yylval.opval->op_private = 0;
3111 /* Resolve to GV now. */
3112 op_free(yylval.opval);
3113 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3114 /* Is there a prototype? */
3117 PL_last_proto = SvPV((SV*)cv, len);
3120 if (strEQ(PL_last_proto, "$"))
3122 if (*PL_last_proto == '&' && *s == '{') {
3123 sv_setpv(PL_subname,"__ANON__");
3127 PL_last_proto = NULL;
3128 PL_nextval[PL_nexttoke].opval = yylval.opval;
3134 if (PL_hints & HINT_STRICT_SUBS &&
3137 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3138 PL_last_lop_op != OP_ACCEPT &&
3139 PL_last_lop_op != OP_PIPE_OP &&
3140 PL_last_lop_op != OP_SOCKPAIR)
3143 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3148 /* Call it a bare word */
3152 if (lastchar != '-') {
3153 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3155 warn(warn_reserved, PL_tokenbuf);
3160 if (lastchar && strchr("*%&", lastchar)) {
3161 warn("Operator or semicolon missing before %c%s",
3162 lastchar, PL_tokenbuf);
3163 warn("Ambiguous use of %c resolved as operator %c",
3164 lastchar, lastchar);
3170 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3171 newSVsv(GvSV(PL_curcop->cop_filegv)));
3175 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3176 newSVpvf("%ld", (long)PL_curcop->cop_line));
3179 case KEY___PACKAGE__:
3180 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3182 ? newSVsv(PL_curstname)
3191 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3192 char *pname = "main";
3193 if (PL_tokenbuf[2] == 'D')
3194 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3195 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3198 GvIOp(gv) = newIO();
3199 IoIFP(GvIOp(gv)) = PL_rsfp;
3200 #if defined(HAS_FCNTL) && defined(F_SETFD)
3202 int fd = PerlIO_fileno(PL_rsfp);
3203 fcntl(fd,F_SETFD,fd >= 3);
3206 /* Mark this internal pseudo-handle as clean */
3207 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3209 IoTYPE(GvIOp(gv)) = '|';
3210 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3211 IoTYPE(GvIOp(gv)) = '-';
3213 IoTYPE(GvIOp(gv)) = '<';
3224 if (PL_expect == XSTATE) {
3231 if (*s == ':' && s[1] == ':') {
3234 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3235 tmp = keyword(PL_tokenbuf, len);
3249 LOP(OP_ACCEPT,XTERM);
3255 LOP(OP_ATAN2,XTERM);
3264 LOP(OP_BLESS,XTERM);
3273 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3290 if (!PL_cryptseen++)
3293 LOP(OP_CRYPT,XTERM);
3297 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3298 if (*d != '0' && isDIGIT(*d))
3299 yywarn("chmod: mode argument is missing initial 0");
3301 LOP(OP_CHMOD,XTERM);
3304 LOP(OP_CHOWN,XTERM);
3307 LOP(OP_CONNECT,XTERM);
3323 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3327 PL_hints |= HINT_BLOCK_SCOPE;
3337 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3338 LOP(OP_DBMOPEN,XTERM);
3344 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3351 yylval.ival = PL_curcop->cop_line;
3365 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3366 UNIBRACK(OP_ENTEREVAL);
3381 case KEY_endhostent:
3387 case KEY_endservent:
3390 case KEY_endprotoent:
3401 yylval.ival = PL_curcop->cop_line;
3403 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3405 if ((PL_bufend - p) >= 3 &&
3406 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3410 croak("Missing $ on loop variable");
3415 LOP(OP_FORMLINE,XTERM);
3421 LOP(OP_FCNTL,XTERM);
3427 LOP(OP_FLOCK,XTERM);
3436 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3439 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3454 case KEY_getpriority:
3455 LOP(OP_GETPRIORITY,XTERM);
3457 case KEY_getprotobyname:
3460 case KEY_getprotobynumber:
3461 LOP(OP_GPBYNUMBER,XTERM);
3463 case KEY_getprotoent:
3475 case KEY_getpeername:
3476 UNI(OP_GETPEERNAME);
3478 case KEY_gethostbyname:
3481 case KEY_gethostbyaddr:
3482 LOP(OP_GHBYADDR,XTERM);
3484 case KEY_gethostent:
3487 case KEY_getnetbyname:
3490 case KEY_getnetbyaddr:
3491 LOP(OP_GNBYADDR,XTERM);
3496 case KEY_getservbyname:
3497 LOP(OP_GSBYNAME,XTERM);
3499 case KEY_getservbyport:
3500 LOP(OP_GSBYPORT,XTERM);
3502 case KEY_getservent:
3505 case KEY_getsockname:
3506 UNI(OP_GETSOCKNAME);
3508 case KEY_getsockopt:
3509 LOP(OP_GSOCKOPT,XTERM);
3531 yylval.ival = PL_curcop->cop_line;
3535 LOP(OP_INDEX,XTERM);
3541 LOP(OP_IOCTL,XTERM);
3553 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3584 LOP(OP_LISTEN,XTERM);
3593 s = scan_pat(s,OP_MATCH);
3594 TERM(sublex_start());
3597 LOP(OP_MAPSTART,XREF);
3600 LOP(OP_MKDIR,XTERM);
3603 LOP(OP_MSGCTL,XTERM);
3606 LOP(OP_MSGGET,XTERM);
3609 LOP(OP_MSGRCV,XTERM);
3612 LOP(OP_MSGSND,XTERM);
3617 if (isIDFIRST(*s)) {
3618 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3619 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3620 if (!PL_in_my_stash) {
3623 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3630 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3637 if (PL_expect != XSTATE)
3638 yyerror("\"no\" not allowed in expression");
3639 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3640 s = force_version(s);
3649 if (isIDFIRST(*s)) {
3651 for (d = s; isALNUM(*d); d++) ;
3653 if (strchr("|&*+-=!?:.", *t))
3654 warn("Precedence problem: open %.*s should be open(%.*s)",
3660 yylval.ival = OP_OR;
3670 LOP(OP_OPEN_DIR,XTERM);
3673 checkcomma(s,PL_tokenbuf,"filehandle");
3677 checkcomma(s,PL_tokenbuf,"filehandle");
3696 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3700 LOP(OP_PIPE_OP,XTERM);
3705 missingterm((char*)0);
3706 yylval.ival = OP_CONST;
3707 TERM(sublex_start());
3715 missingterm((char*)0);
3716 if (PL_dowarn && SvLEN(PL_lex_stuff)) {
3717 d = SvPV_force(PL_lex_stuff, len);
3718 for (; len; --len, ++d) {
3720 warn("Possible attempt to separate words with commas");
3724 warn("Possible attempt to put comments in qw() list");
3730 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3731 PL_lex_stuff = Nullsv;
3734 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3737 yylval.ival = OP_SPLIT;
3741 PL_last_lop = PL_oldbufptr;
3742 PL_last_lop_op = OP_SPLIT;
3748 missingterm((char*)0);
3749 yylval.ival = OP_STRINGIFY;
3750 if (SvIVX(PL_lex_stuff) == '\'')
3751 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3752 TERM(sublex_start());
3755 s = scan_pat(s,OP_QR);
3756 TERM(sublex_start());
3761 missingterm((char*)0);
3762 yylval.ival = OP_BACKTICK;
3764 TERM(sublex_start());
3770 *PL_tokenbuf = '\0';
3771 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3772 if (isIDFIRST(*PL_tokenbuf))
3773 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3775 yyerror("<> should be quotes");
3782 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3786 LOP(OP_RENAME,XTERM);
3795 LOP(OP_RINDEX,XTERM);
3818 LOP(OP_REVERSE,XTERM);
3829 TERM(sublex_start());
3831 TOKEN(1); /* force error */
3840 LOP(OP_SELECT,XTERM);
3846 LOP(OP_SEMCTL,XTERM);
3849 LOP(OP_SEMGET,XTERM);
3852 LOP(OP_SEMOP,XTERM);
3858 LOP(OP_SETPGRP,XTERM);
3860 case KEY_setpriority:
3861 LOP(OP_SETPRIORITY,XTERM);
3863 case KEY_sethostent:
3869 case KEY_setservent:
3872 case KEY_setprotoent:
3882 LOP(OP_SEEKDIR,XTERM);
3884 case KEY_setsockopt:
3885 LOP(OP_SSOCKOPT,XTERM);
3891 LOP(OP_SHMCTL,XTERM);
3894 LOP(OP_SHMGET,XTERM);
3897 LOP(OP_SHMREAD,XTERM);
3900 LOP(OP_SHMWRITE,XTERM);
3903 LOP(OP_SHUTDOWN,XTERM);
3912 LOP(OP_SOCKET,XTERM);
3914 case KEY_socketpair:
3915 LOP(OP_SOCKPAIR,XTERM);
3918 checkcomma(s,PL_tokenbuf,"subroutine name");
3920 if (*s == ';' || *s == ')') /* probably a close */
3921 croak("sort is now a reserved word");
3923 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3927 LOP(OP_SPLIT,XTERM);
3930 LOP(OP_SPRINTF,XTERM);
3933 LOP(OP_SPLICE,XTERM);
3949 LOP(OP_SUBSTR,XTERM);
3956 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3957 char tmpbuf[sizeof PL_tokenbuf];
3959 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3960 if (strchr(tmpbuf, ':'))
3961 sv_setpv(PL_subname, tmpbuf);
3963 sv_setsv(PL_subname,PL_curstname);
3964 sv_catpvn(PL_subname,"::",2);
3965 sv_catpvn(PL_subname,tmpbuf,len);
3967 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3971 PL_expect = XTERMBLOCK;
3972 sv_setpv(PL_subname,"?");
3975 if (tmp == KEY_format) {
3978 PL_lex_formbrack = PL_lex_brackets + 1;
3982 /* Look for a prototype */
3989 SvREFCNT_dec(PL_lex_stuff);
3990 PL_lex_stuff = Nullsv;
3991 croak("Prototype not terminated");
3994 d = SvPVX(PL_lex_stuff);
3996 for (p = d; *p; ++p) {
4001 SvCUR(PL_lex_stuff) = tmp;
4004 PL_nextval[1] = PL_nextval[0];
4005 PL_nexttype[1] = PL_nexttype[0];
4006 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4007 PL_nexttype[0] = THING;
4008 if (PL_nexttoke == 1) {
4009 PL_lex_defer = PL_lex_state;
4010 PL_lex_expect = PL_expect;
4011 PL_lex_state = LEX_KNOWNEXT;
4013 PL_lex_stuff = Nullsv;
4016 if (*SvPV(PL_subname,PL_na) == '?') {
4017 sv_setpv(PL_subname,"__ANON__");
4024 LOP(OP_SYSTEM,XREF);
4027 LOP(OP_SYMLINK,XTERM);
4030 LOP(OP_SYSCALL,XTERM);
4033 LOP(OP_SYSOPEN,XTERM);
4036 LOP(OP_SYSSEEK,XTERM);
4039 LOP(OP_SYSREAD,XTERM);
4042 LOP(OP_SYSWRITE,XTERM);
4046 TERM(sublex_start());
4067 LOP(OP_TRUNCATE,XTERM);
4079 yylval.ival = PL_curcop->cop_line;
4083 yylval.ival = PL_curcop->cop_line;
4087 LOP(OP_UNLINK,XTERM);
4093 LOP(OP_UNPACK,XTERM);
4096 LOP(OP_UTIME,XTERM);
4100 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4101 if (*d != '0' && isDIGIT(*d))
4102 yywarn("umask: argument is missing initial 0");
4107 LOP(OP_UNSHIFT,XTERM);
4110 if (PL_expect != XSTATE)
4111 yyerror("\"use\" not allowed in expression");
4114 s = force_version(s);
4115 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4116 PL_nextval[PL_nexttoke].opval = Nullop;
4121 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4122 s = force_version(s);
4135 yylval.ival = PL_curcop->cop_line;
4139 PL_hints |= HINT_BLOCK_SCOPE;
4146 LOP(OP_WAITPID,XTERM);
4152 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4156 if (PL_expect == XOPERATOR)
4162 yylval.ival = OP_XOR;
4167 TERM(sublex_start());
4173 keyword(register char *d, I32 len)
4178 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4179 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4180 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4181 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4182 if (strEQ(d,"__END__")) return KEY___END__;
4186 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4191 if (strEQ(d,"and")) return -KEY_and;
4192 if (strEQ(d,"abs")) return -KEY_abs;
4195 if (strEQ(d,"alarm")) return -KEY_alarm;
4196 if (strEQ(d,"atan2")) return -KEY_atan2;
4199 if (strEQ(d,"accept")) return -KEY_accept;
4204 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4207 if (strEQ(d,"bless")) return -KEY_bless;
4208 if (strEQ(d,"bind")) return -KEY_bind;
4209 if (strEQ(d,"binmode")) return -KEY_binmode;
4212 if (strEQ(d,"CORE")) return -KEY_CORE;
4217 if (strEQ(d,"cmp")) return -KEY_cmp;
4218 if (strEQ(d,"chr")) return -KEY_chr;
4219 if (strEQ(d,"cos")) return -KEY_cos;
4222 if (strEQ(d,"chop")) return KEY_chop;
4225 if (strEQ(d,"close")) return -KEY_close;
4226 if (strEQ(d,"chdir")) return -KEY_chdir;
4227 if (strEQ(d,"chomp")) return KEY_chomp;
4228 if (strEQ(d,"chmod")) return -KEY_chmod;
4229 if (strEQ(d,"chown")) return -KEY_chown;
4230 if (strEQ(d,"crypt")) return -KEY_crypt;
4233 if (strEQ(d,"chroot")) return -KEY_chroot;
4234 if (strEQ(d,"caller")) return -KEY_caller;
4237 if (strEQ(d,"connect")) return -KEY_connect;
4240 if (strEQ(d,"closedir")) return -KEY_closedir;
4241 if (strEQ(d,"continue")) return -KEY_continue;
4246 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4251 if (strEQ(d,"do")) return KEY_do;
4254 if (strEQ(d,"die")) return -KEY_die;
4257 if (strEQ(d,"dump")) return -KEY_dump;
4260 if (strEQ(d,"delete")) return KEY_delete;
4263 if (strEQ(d,"defined")) return KEY_defined;
4264 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4267 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4272 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4273 if (strEQ(d,"END")) return KEY_END;
4278 if (strEQ(d,"eq")) return -KEY_eq;
4281 if (strEQ(d,"eof")) return -KEY_eof;
4282 if (strEQ(d,"exp")) return -KEY_exp;
4285 if (strEQ(d,"else")) return KEY_else;
4286 if (strEQ(d,"exit")) return -KEY_exit;
4287 if (strEQ(d,"eval")) return KEY_eval;
4288 if (strEQ(d,"exec")) return -KEY_exec;
4289 if (strEQ(d,"each")) return KEY_each;
4292 if (strEQ(d,"elsif")) return KEY_elsif;
4295 if (strEQ(d,"exists")) return KEY_exists;
4296 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4299 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4300 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4303 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4306 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4307 if (strEQ(d,"endservent")) return -KEY_endservent;
4310 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4317 if (strEQ(d,"for")) return KEY_for;
4320 if (strEQ(d,"fork")) return -KEY_fork;
4323 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4324 if (strEQ(d,"flock")) return -KEY_flock;
4327 if (strEQ(d,"format")) return KEY_format;
4328 if (strEQ(d,"fileno")) return -KEY_fileno;
4331 if (strEQ(d,"foreach")) return KEY_foreach;
4334 if (strEQ(d,"formline")) return -KEY_formline;
4340 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4341 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4345 if (strnEQ(d,"get",3)) {
4350 if (strEQ(d,"ppid")) return -KEY_getppid;
4351 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4354 if (strEQ(d,"pwent")) return -KEY_getpwent;
4355 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4356 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4359 if (strEQ(d,"peername")) return -KEY_getpeername;
4360 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4361 if (strEQ(d,"priority")) return -KEY_getpriority;
4364 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4367 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4371 else if (*d == 'h') {
4372 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4373 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4374 if (strEQ(d,"hostent")) return -KEY_gethostent;
4376 else if (*d == 'n') {
4377 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4378 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4379 if (strEQ(d,"netent")) return -KEY_getnetent;
4381 else if (*d == 's') {
4382 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4383 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4384 if (strEQ(d,"servent")) return -KEY_getservent;
4385 if (strEQ(d,"sockname")) return -KEY_getsockname;
4386 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4388 else if (*d == 'g') {
4389 if (strEQ(d,"grent")) return -KEY_getgrent;
4390 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4391 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4393 else if (*d == 'l') {
4394 if (strEQ(d,"login")) return -KEY_getlogin;
4396 else if (strEQ(d,"c")) return -KEY_getc;
4401 if (strEQ(d,"gt")) return -KEY_gt;
4402 if (strEQ(d,"ge")) return -KEY_ge;
4405 if (strEQ(d,"grep")) return KEY_grep;
4406 if (strEQ(d,"goto")) return KEY_goto;
4407 if (strEQ(d,"glob")) return KEY_glob;
4410 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4415 if (strEQ(d,"hex")) return -KEY_hex;
4418 if (strEQ(d,"INIT")) return KEY_INIT;
4423 if (strEQ(d,"if")) return KEY_if;
4426 if (strEQ(d,"int")) return -KEY_int;
4429 if (strEQ(d,"index")) return -KEY_index;
4430 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4435 if (strEQ(d,"join")) return -KEY_join;
4439 if (strEQ(d,"keys")) return KEY_keys;
4440 if (strEQ(d,"kill")) return -KEY_kill;
4445 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4446 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4452 if (strEQ(d,"lt")) return -KEY_lt;
4453 if (strEQ(d,"le")) return -KEY_le;
4454 if (strEQ(d,"lc")) return -KEY_lc;
4457 if (strEQ(d,"log")) return -KEY_log;
4460 if (strEQ(d,"last")) return KEY_last;
4461 if (strEQ(d,"link")) return -KEY_link;
4462 if (strEQ(d,"lock")) return -KEY_lock;
4465 if (strEQ(d,"local")) return KEY_local;
4466 if (strEQ(d,"lstat")) return -KEY_lstat;
4469 if (strEQ(d,"length")) return -KEY_length;
4470 if (strEQ(d,"listen")) return -KEY_listen;
4473 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4476 if (strEQ(d,"localtime")) return -KEY_localtime;
4482 case 1: return KEY_m;
4484 if (strEQ(d,"my")) return KEY_my;
4487 if (strEQ(d,"map")) return KEY_map;
4490 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4493 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4494 if (strEQ(d,"msgget")) return -KEY_msgget;
4495 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4496 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4501 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4504 if (strEQ(d,"next")) return KEY_next;
4505 if (strEQ(d,"ne")) return -KEY_ne;
4506 if (strEQ(d,"not")) return -KEY_not;
4507 if (strEQ(d,"no")) return KEY_no;
4512 if (strEQ(d,"or")) return -KEY_or;
4515 if (strEQ(d,"ord")) return -KEY_ord;
4516 if (strEQ(d,"oct")) return -KEY_oct;
4517 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4521 if (strEQ(d,"open")) return -KEY_open;
4524 if (strEQ(d,"opendir")) return -KEY_opendir;
4531 if (strEQ(d,"pop")) return KEY_pop;
4532 if (strEQ(d,"pos")) return KEY_pos;
4535 if (strEQ(d,"push")) return KEY_push;
4536 if (strEQ(d,"pack")) return -KEY_pack;
4537 if (strEQ(d,"pipe")) return -KEY_pipe;
4540 if (strEQ(d,"print")) return KEY_print;
4543 if (strEQ(d,"printf")) return KEY_printf;
4546 if (strEQ(d,"package")) return KEY_package;
4549 if (strEQ(d,"prototype")) return KEY_prototype;
4554 if (strEQ(d,"q")) return KEY_q;
4555 if (strEQ(d,"qr")) return KEY_qr;
4556 if (strEQ(d,"qq")) return KEY_qq;
4557 if (strEQ(d,"qw")) return KEY_qw;
4558 if (strEQ(d,"qx")) return KEY_qx;
4560 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4565 if (strEQ(d,"ref")) return -KEY_ref;
4568 if (strEQ(d,"read")) return -KEY_read;
4569 if (strEQ(d,"rand")) return -KEY_rand;
4570 if (strEQ(d,"recv")) return -KEY_recv;
4571 if (strEQ(d,"redo")) return KEY_redo;
4574 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4575 if (strEQ(d,"reset")) return -KEY_reset;
4578 if (strEQ(d,"return")) return KEY_return;
4579 if (strEQ(d,"rename")) return -KEY_rename;
4580 if (strEQ(d,"rindex")) return -KEY_rindex;
4583 if (strEQ(d,"require")) return -KEY_require;
4584 if (strEQ(d,"reverse")) return -KEY_reverse;
4585 if (strEQ(d,"readdir")) return -KEY_readdir;
4588 if (strEQ(d,"readlink")) return -KEY_readlink;
4589 if (strEQ(d,"readline")) return -KEY_readline;
4590 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4593 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4599 case 0: return KEY_s;
4601 if (strEQ(d,"scalar")) return KEY_scalar;
4606 if (strEQ(d,"seek")) return -KEY_seek;
4607 if (strEQ(d,"send")) return -KEY_send;
4610 if (strEQ(d,"semop")) return -KEY_semop;
4613 if (strEQ(d,"select")) return -KEY_select;
4614 if (strEQ(d,"semctl")) return -KEY_semctl;
4615 if (strEQ(d,"semget")) return -KEY_semget;
4618 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4619 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4622 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4623 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4626 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4629 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4630 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4631 if (strEQ(d,"setservent")) return -KEY_setservent;
4634 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4635 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4642 if (strEQ(d,"shift")) return KEY_shift;
4645 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4646 if (strEQ(d,"shmget")) return -KEY_shmget;
4649 if (strEQ(d,"shmread")) return -KEY_shmread;
4652 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4653 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4658 if (strEQ(d,"sin")) return -KEY_sin;
4661 if (strEQ(d,"sleep")) return -KEY_sleep;
4664 if (strEQ(d,"sort")) return KEY_sort;
4665 if (strEQ(d,"socket")) return -KEY_socket;
4666 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4669 if (strEQ(d,"split")) return KEY_split;
4670 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4671 if (strEQ(d,"splice")) return KEY_splice;
4674 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4677 if (strEQ(d,"srand")) return -KEY_srand;
4680 if (strEQ(d,"stat")) return -KEY_stat;
4681 if (strEQ(d,"study")) return KEY_study;
4684 if (strEQ(d,"substr")) return -KEY_substr;
4685 if (strEQ(d,"sub")) return KEY_sub;
4690 if (strEQ(d,"system")) return -KEY_system;
4693 if (strEQ(d,"symlink")) return -KEY_symlink;
4694 if (strEQ(d,"syscall")) return -KEY_syscall;
4695 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4696 if (strEQ(d,"sysread")) return -KEY_sysread;
4697 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4700 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4709 if (strEQ(d,"tr")) return KEY_tr;
4712 if (strEQ(d,"tie")) return KEY_tie;
4715 if (strEQ(d,"tell")) return -KEY_tell;
4716 if (strEQ(d,"tied")) return KEY_tied;
4717 if (strEQ(d,"time")) return -KEY_time;
4720 if (strEQ(d,"times")) return -KEY_times;
4723 if (strEQ(d,"telldir")) return -KEY_telldir;
4726 if (strEQ(d,"truncate")) return -KEY_truncate;
4733 if (strEQ(d,"uc")) return -KEY_uc;
4736 if (strEQ(d,"use")) return KEY_use;
4739 if (strEQ(d,"undef")) return KEY_undef;
4740 if (strEQ(d,"until")) return KEY_until;
4741 if (strEQ(d,"untie")) return KEY_untie;
4742 if (strEQ(d,"utime")) return -KEY_utime;
4743 if (strEQ(d,"umask")) return -KEY_umask;
4746 if (strEQ(d,"unless")) return KEY_unless;
4747 if (strEQ(d,"unpack")) return -KEY_unpack;
4748 if (strEQ(d,"unlink")) return -KEY_unlink;
4751 if (strEQ(d,"unshift")) return KEY_unshift;
4752 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4757 if (strEQ(d,"values")) return -KEY_values;
4758 if (strEQ(d,"vec")) return -KEY_vec;
4763 if (strEQ(d,"warn")) return -KEY_warn;
4764 if (strEQ(d,"wait")) return -KEY_wait;
4767 if (strEQ(d,"while")) return KEY_while;
4768 if (strEQ(d,"write")) return -KEY_write;
4771 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4774 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4779 if (len == 1) return -KEY_x;
4780 if (strEQ(d,"xor")) return -KEY_xor;
4783 if (len == 1) return KEY_y;
4792 checkcomma(register char *s, char *name, char *what)
4796 if (PL_dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4798 for (w = s+2; *w && level; w++) {
4805 for (; *w && isSPACE(*w); w++) ;
4806 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4807 warn("%s (...) interpreted as function",name);
4809 while (s < PL_bufend && isSPACE(*s))
4813 while (s < PL_bufend && isSPACE(*s))
4815 if (isIDFIRST(*s)) {
4819 while (s < PL_bufend && isSPACE(*s))
4824 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4828 croak("No comma allowed after %s", what);
4834 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4837 HV *table = GvHV(PL_hintgv); /* ^H */
4840 bool oldcatch = CATCH_GET;
4846 yyerror("%^H is not defined");
4849 cvp = hv_fetch(table, key, strlen(key), FALSE);
4850 if (!cvp || !SvOK(*cvp)) {
4851 sprintf(buf,"$^H{%s} is not defined", key);
4855 sv_2mortal(sv); /* Parent created it permanently */
4858 pv = sv_2mortal(newSVpv(s, len));
4860 typesv = sv_2mortal(newSVpv(type, 0));
4862 typesv = &PL_sv_undef;
4864 Zero(&myop, 1, BINOP);
4865 myop.op_last = (OP *) &myop;
4866 myop.op_next = Nullop;
4867 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4869 PUSHSTACKi(PERLSI_OVERLOAD);
4872 PL_op = (OP *) &myop;
4873 if (PERLDB_SUB && PL_curstash != PL_debstash)
4874 PL_op->op_private |= OPpENTERSUB_DB;
4885 if (PL_op = pp_entersub(ARGS))
4892 CATCH_SET(oldcatch);
4896 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4899 return SvREFCNT_inc(res);
4903 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4905 register char *d = dest;
4906 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4909 croak(ident_too_long);
4912 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4917 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4921 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8(s)) {
4922 char *t = s + UTF8SKIP(s);
4923 while (*t & 0x80 && is_utf8_mark(t))
4925 if (d + (t - s) > e)
4926 croak(ident_too_long);
4927 Copy(s, d, t - s, char);
4940 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4947 if (PL_lex_brackets == 0)
4948 PL_lex_fakebrack = 0;
4952 e = d + destlen - 3; /* two-character token, ending NUL */
4954 while (isDIGIT(*s)) {
4956 croak(ident_too_long);
4963 croak(ident_too_long);
4966 else if (*s == '\'' && isIDFIRST(s[1])) {
4971 else if (*s == ':' && s[1] == ':') {
4975 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8(s)) {
4976 char *t = s + UTF8SKIP(s);
4977 while (*t & 0x80 && is_utf8_mark(t))
4979 if (d + (t - s) > e)
4980 croak(ident_too_long);
4981 Copy(s, d, t - s, char);
4992 if (PL_lex_state != LEX_NORMAL)
4993 PL_lex_state = LEX_INTERPENDMAYBE;
4996 if (*s == '$' && s[1] &&
4997 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
4999 if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
5000 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
5013 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5018 if (isSPACE(s[-1])) {
5021 if (ch != ' ' && ch != '\t') {
5027 if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8(d))) {
5031 while (e < send && (isALNUM(*e) || ((*e & 0xc0) == 0x80 && isALNUM_utf8((U8*)e)) || *e == ':')) {
5033 while (e < send && *e & 0x80 && is_utf8_mark(e))
5036 Copy(s, d, e - s, char);
5041 while (isALNUM(*s) || *s == ':')
5045 while (s < send && (*s == ' ' || *s == '\t')) s++;
5046 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5047 if (PL_dowarn && keyword(dest, d - dest)) {
5048 char *brack = *s == '[' ? "[...]" : "{...}";
5049 warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
5050 funny, dest, brack, funny, dest, brack);
5052 PL_lex_fakebrack = PL_lex_brackets+1;
5054 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5060 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5061 PL_lex_state = LEX_INTERPEND;
5064 if (PL_dowarn && PL_lex_state == LEX_NORMAL &&
5065 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5066 warn("Ambiguous use of %c{%s} resolved to %c%s",
5067 funny, dest, funny, dest);
5070 s = bracket; /* let the parser handle it */
5074 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5075 PL_lex_state = LEX_INTERPEND;
5079 void pmflag(U16 *pmfl, int ch)
5084 *pmfl |= PMf_GLOBAL;
5086 *pmfl |= PMf_CONTINUE;
5090 *pmfl |= PMf_MULTILINE;
5092 *pmfl |= PMf_SINGLELINE;
5094 *pmfl |= PMf_EXTENDED;
5098 scan_pat(char *start, I32 type)
5103 s = scan_str(start);
5106 SvREFCNT_dec(PL_lex_stuff);
5107 PL_lex_stuff = Nullsv;
5108 croak("Search pattern not terminated");
5111 pm = (PMOP*)newPMOP(type, 0);
5112 if (PL_multi_open == '?')
5113 pm->op_pmflags |= PMf_ONCE;
5115 while (*s && strchr("iomsx", *s))
5116 pmflag(&pm->op_pmflags,*s++);
5119 while (*s && strchr("iogcmsx", *s))
5120 pmflag(&pm->op_pmflags,*s++);
5122 pm->op_pmpermflags = pm->op_pmflags;
5124 PL_lex_op = (OP*)pm;
5125 yylval.ival = OP_MATCH;
5130 scan_subst(char *start)
5137 yylval.ival = OP_NULL;
5139 s = scan_str(start);
5143 SvREFCNT_dec(PL_lex_stuff);
5144 PL_lex_stuff = Nullsv;
5145 croak("Substitution pattern not terminated");
5148 if (s[-1] == PL_multi_open)
5151 first_start = PL_multi_start;
5155 SvREFCNT_dec(PL_lex_stuff);
5156 PL_lex_stuff = Nullsv;
5158 SvREFCNT_dec(PL_lex_repl);
5159 PL_lex_repl = Nullsv;
5160 croak("Substitution replacement not terminated");
5162 PL_multi_start = first_start; /* so whole substitution is taken together */
5164 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5170 else if (strchr("iogcmsx", *s))
5171 pmflag(&pm->op_pmflags,*s++);
5178 pm->op_pmflags |= PMf_EVAL;
5179 repl = newSVpv("",0);
5181 sv_catpv(repl, es ? "eval " : "do ");
5182 sv_catpvn(repl, "{ ", 2);
5183 sv_catsv(repl, PL_lex_repl);
5184 sv_catpvn(repl, " };", 2);
5185 SvCOMPILED_on(repl);
5186 SvREFCNT_dec(PL_lex_repl);
5190 pm->op_pmpermflags = pm->op_pmflags;
5191 PL_lex_op = (OP*)pm;
5192 yylval.ival = OP_SUBST;
5197 scan_trans(char *start)
5208 yylval.ival = OP_NULL;
5210 s = scan_str(start);
5213 SvREFCNT_dec(PL_lex_stuff);
5214 PL_lex_stuff = Nullsv;
5215 croak("Transliteration pattern not terminated");
5217 if (s[-1] == PL_multi_open)
5223 SvREFCNT_dec(PL_lex_stuff);
5224 PL_lex_stuff = Nullsv;
5226 SvREFCNT_dec(PL_lex_repl);
5227 PL_lex_repl = Nullsv;
5228 croak("Transliteration replacement not terminated");
5232 o = newSVOP(OP_TRANS, 0, 0);
5233 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5236 New(803,tbl,256,short);
5237 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5241 complement = del = squash = 0;
5242 while (strchr("cdsCU", *s)) {
5244 complement = OPpTRANS_COMPLEMENT;
5246 del = OPpTRANS_DELETE;
5248 squash = OPpTRANS_SQUASH;
5253 utf8 &= ~OPpTRANS_FROM_UTF;
5255 utf8 |= OPpTRANS_FROM_UTF;
5259 utf8 &= ~OPpTRANS_TO_UTF;
5261 utf8 |= OPpTRANS_TO_UTF;
5264 croak("Too many /C and /U options");
5269 o->op_private = del|squash|complement|utf8;
5272 yylval.ival = OP_TRANS;
5277 scan_heredoc(register char *s)
5281 I32 op_type = OP_SCALAR;
5288 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5292 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5295 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5296 if (*peek && strchr("`'\"",*peek)) {
5299 s = delimcpy(d, e, s, PL_bufend, term, &len);
5310 deprecate("bare << to mean <<\"\"");
5311 for (; isALNUM(*s); s++) {
5316 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5317 croak("Delimiter for here document is too long");
5320 len = d - PL_tokenbuf;
5321 #ifdef TMP_CRLF_PATCH
5322 d = strchr(s, '\r');
5326 while (s < PL_bufend) {
5332 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5341 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5346 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5347 herewas = newSVpv(s,PL_bufend-s);
5349 s--, herewas = newSVpv(s,d-s);
5350 s += SvCUR(herewas);
5352 tmpstr = NEWSV(87,79);
5353 sv_upgrade(tmpstr, SVt_PVIV);
5358 else if (term == '`') {
5359 op_type = OP_BACKTICK;
5360 SvIVX(tmpstr) = '\\';
5364 PL_multi_start = PL_curcop->cop_line;
5365 PL_multi_open = PL_multi_close = '<';
5366 term = *PL_tokenbuf;
5369 while (s < PL_bufend &&
5370 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5372 PL_curcop->cop_line++;
5374 if (s >= PL_bufend) {
5375 PL_curcop->cop_line = PL_multi_start;
5376 missingterm(PL_tokenbuf);
5378 sv_setpvn(tmpstr,d+1,s-d);
5380 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5382 sv_catpvn(herewas,s,PL_bufend-s);
5383 sv_setsv(PL_linestr,herewas);
5384 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5385 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5388 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5389 while (s >= PL_bufend) { /* multiple line string? */
5391 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5392 PL_curcop->cop_line = PL_multi_start;
5393 missingterm(PL_tokenbuf);
5395 PL_curcop->cop_line++;
5396 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5397 #ifdef TMP_CRLF_PATCH
5398 if (PL_bufend - PL_linestart >= 2) {
5399 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5400 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5402 PL_bufend[-2] = '\n';
5404 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5406 else if (PL_bufend[-1] == '\r')
5407 PL_bufend[-1] = '\n';
5409 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5410 PL_bufend[-1] = '\n';
5412 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5413 SV *sv = NEWSV(88,0);
5415 sv_upgrade(sv, SVt_PVMG);
5416 sv_setsv(sv,PL_linestr);
5417 av_store(GvAV(PL_curcop->cop_filegv),
5418 (I32)PL_curcop->cop_line,sv);
5420 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5423 sv_catsv(PL_linestr,herewas);
5424 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5428 sv_catsv(tmpstr,PL_linestr);
5431 PL_multi_end = PL_curcop->cop_line;
5433 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5434 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5435 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5437 SvREFCNT_dec(herewas);
5438 PL_lex_stuff = tmpstr;
5439 yylval.ival = op_type;
5444 takes: current position in input buffer
5445 returns: new position in input buffer
5446 side-effects: yylval and lex_op are set.
5451 <FH> read from filehandle
5452 <pkg::FH> read from package qualified filehandle
5453 <pkg'FH> read from package qualified filehandle
5454 <$fh> read from filehandle in $fh
5460 scan_inputsymbol(char *start)
5462 register char *s = start; /* current position in buffer */
5467 d = PL_tokenbuf; /* start of temp holding space */
5468 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5469 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5471 /* die if we didn't have space for the contents of the <>,
5475 if (len >= sizeof PL_tokenbuf)
5476 croak("Excessively long <> operator");
5478 croak("Unterminated <> operator");
5483 Remember, only scalar variables are interpreted as filehandles by
5484 this code. Anything more complex (e.g., <$fh{$num}>) will be
5485 treated as a glob() call.
5486 This code makes use of the fact that except for the $ at the front,
5487 a scalar variable and a filehandle look the same.
5489 if (*d == '$' && d[1]) d++;
5491 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5492 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5495 /* If we've tried to read what we allow filehandles to look like, and
5496 there's still text left, then it must be a glob() and not a getline.
5497 Use scan_str to pull out the stuff between the <> and treat it
5498 as nothing more than a string.
5501 if (d - PL_tokenbuf != len) {
5502 yylval.ival = OP_GLOB;
5504 s = scan_str(start);
5506 croak("Glob not terminated");
5510 /* we're in a filehandle read situation */
5513 /* turn <> into <ARGV> */
5515 (void)strcpy(d,"ARGV");
5517 /* if <$fh>, create the ops to turn the variable into a
5523 /* try to find it in the pad for this block, otherwise find
5524 add symbol table ops
5526 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5527 OP *o = newOP(OP_PADSV, 0);
5529 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5532 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5533 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5534 newUNOP(OP_RV2GV, 0,
5535 newUNOP(OP_RV2SV, 0,
5536 newGVOP(OP_GV, 0, gv))));
5538 /* we created the ops in lex_op, so make yylval.ival a null op */
5539 yylval.ival = OP_NULL;
5542 /* If it's none of the above, it must be a literal filehandle
5543 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5545 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5546 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5547 yylval.ival = OP_NULL;
5556 takes: start position in buffer
5557 returns: position to continue reading from buffer
5558 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5559 updates the read buffer.
5561 This subroutine pulls a string out of the input. It is called for:
5562 q single quotes q(literal text)
5563 ' single quotes 'literal text'
5564 qq double quotes qq(interpolate $here please)
5565 " double quotes "interpolate $here please"
5566 qx backticks qx(/bin/ls -l)
5567 ` backticks `/bin/ls -l`
5568 qw quote words @EXPORT_OK = qw( func() $spam )
5569 m// regexp match m/this/
5570 s/// regexp substitute s/this/that/
5571 tr/// string transliterate tr/this/that/
5572 y/// string transliterate y/this/that/
5573 ($*@) sub prototypes sub foo ($)
5574 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5576 In most of these cases (all but <>, patterns and transliterate)
5577 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5578 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5579 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5582 It skips whitespace before the string starts, and treats the first
5583 character as the delimiter. If the delimiter is one of ([{< then
5584 the corresponding "close" character )]}> is used as the closing
5585 delimiter. It allows quoting of delimiters, and if the string has
5586 balanced delimiters ([{<>}]) it allows nesting.
5588 The lexer always reads these strings into lex_stuff, except in the
5589 case of the operators which take *two* arguments (s/// and tr///)
5590 when it checks to see if lex_stuff is full (presumably with the 1st
5591 arg to s or tr) and if so puts the string into lex_repl.
5596 scan_str(char *start)
5599 SV *sv; /* scalar value: string */
5600 char *tmps; /* temp string, used for delimiter matching */
5601 register char *s = start; /* current position in the buffer */
5602 register char term; /* terminating character */
5603 register char *to; /* current position in the sv's data */
5604 I32 brackets = 1; /* bracket nesting level */
5606 /* skip space before the delimiter */
5610 /* mark where we are, in case we need to report errors */
5613 /* after skipping whitespace, the next character is the terminator */
5615 /* mark where we are */
5616 PL_multi_start = PL_curcop->cop_line;
5617 PL_multi_open = term;
5619 /* find corresponding closing delimiter */
5620 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5622 PL_multi_close = term;
5624 /* create a new SV to hold the contents. 87 is leak category, I'm
5625 assuming. 79 is the SV's initial length. What a random number. */
5627 sv_upgrade(sv, SVt_PVIV);
5629 (void)SvPOK_only(sv); /* validate pointer */
5631 /* move past delimiter and try to read a complete string */
5634 /* extend sv if need be */
5635 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5636 /* set 'to' to the next character in the sv's string */
5637 to = SvPVX(sv)+SvCUR(sv);
5639 /* if open delimiter is the close delimiter read unbridle */
5640 if (PL_multi_open == PL_multi_close) {
5641 for (; s < PL_bufend; s++,to++) {
5642 /* embedded newlines increment the current line number */
5643 if (*s == '\n' && !PL_rsfp)
5644 PL_curcop->cop_line++;
5645 /* handle quoted delimiters */
5646 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5649 /* any other quotes are simply copied straight through */
5653 /* terminate when run out of buffer (the for() condition), or
5654 have found the terminator */
5655 else if (*s == term)
5661 /* if the terminator isn't the same as the start character (e.g.,
5662 matched brackets), we have to allow more in the quoting, and
5663 be prepared for nested brackets.
5666 /* read until we run out of string, or we find the terminator */
5667 for (; s < PL_bufend; s++,to++) {
5668 /* embedded newlines increment the line count */
5669 if (*s == '\n' && !PL_rsfp)
5670 PL_curcop->cop_line++;
5671 /* backslashes can escape the open or closing characters */
5672 if (*s == '\\' && s+1 < PL_bufend) {
5673 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5678 /* allow nested opens and closes */
5679 else if (*s == PL_multi_close && --brackets <= 0)
5681 else if (*s == PL_multi_open)
5686 /* terminate the copied string and update the sv's end-of-string */
5688 SvCUR_set(sv, to - SvPVX(sv));
5691 * this next chunk reads more into the buffer if we're not done yet
5694 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5696 #ifdef TMP_CRLF_PATCH
5697 if (to - SvPVX(sv) >= 2) {
5698 if ((to[-2] == '\r' && to[-1] == '\n') ||
5699 (to[-2] == '\n' && to[-1] == '\r'))
5703 SvCUR_set(sv, to - SvPVX(sv));
5705 else if (to[-1] == '\r')
5708 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5712 /* if we're out of file, or a read fails, bail and reset the current
5713 line marker so we can report where the unterminated string began
5716 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5718 PL_curcop->cop_line = PL_multi_start;
5721 /* we read a line, so increment our line counter */
5722 PL_curcop->cop_line++;
5724 /* update debugger info */
5725 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5726 SV *sv = NEWSV(88,0);
5728 sv_upgrade(sv, SVt_PVMG);
5729 sv_setsv(sv,PL_linestr);
5730 av_store(GvAV(PL_curcop->cop_filegv),
5731 (I32)PL_curcop->cop_line, sv);
5734 /* having changed the buffer, we must update PL_bufend */
5735 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5738 /* at this point, we have successfully read the delimited string */
5740 PL_multi_end = PL_curcop->cop_line;
5743 /* if we allocated too much space, give some back */
5744 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5745 SvLEN_set(sv, SvCUR(sv) + 1);
5746 Renew(SvPVX(sv), SvLEN(sv), char);
5749 /* decide whether this is the first or second quoted string we've read
5762 takes: pointer to position in buffer
5763 returns: pointer to new position in buffer
5764 side-effects: builds ops for the constant in yylval.op
5766 Read a number in any of the formats that Perl accepts:
5768 0(x[0-7A-F]+)|([0-7]+)
5769 [\d_]+(\.[\d_]*)?[Ee](\d+)
5771 Underbars (_) are allowed in decimal numbers. If -w is on,
5772 underbars before a decimal point must be at three digit intervals.
5774 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5777 If it reads a number without a decimal point or an exponent, it will
5778 try converting the number to an integer and see if it can do so
5779 without loss of precision.
5783 scan_num(char *start)
5785 register char *s = start; /* current position in buffer */
5786 register char *d; /* destination in temp buffer */
5787 register char *e; /* end of temp buffer */
5788 I32 tryiv; /* used to see if it can be an int */
5789 double value; /* number read, as a double */
5790 SV *sv; /* place to put the converted number */
5791 I32 floatit; /* boolean: int or float? */
5792 char *lastub = 0; /* position of last underbar */
5793 static char number_too_long[] = "Number too long";
5795 /* We use the first character to decide what type of number this is */
5799 croak("panic: scan_num");
5801 /* if it starts with a 0, it could be an octal number, a decimal in
5802 0.13 disguise, or a hexadecimal number.
5807 u holds the "number so far"
5808 shift the power of 2 of the base (hex == 4, octal == 3)
5809 overflowed was the number more than we can hold?
5811 Shift is used when we add a digit. It also serves as an "are
5812 we in octal or hex?" indicator to disallow hex characters when
5817 bool overflowed = FALSE;
5824 /* check for a decimal in disguise */
5825 else if (s[1] == '.')
5827 /* so it must be octal */
5832 /* read the rest of the octal number */
5834 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5838 /* if we don't mention it, we're done */
5847 /* 8 and 9 are not octal */
5850 yyerror("Illegal octal digit");
5854 case '0': case '1': case '2': case '3': case '4':
5855 case '5': case '6': case '7':
5856 b = *s++ & 15; /* ASCII digit -> value of digit */
5860 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5861 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5862 /* make sure they said 0x */
5867 /* Prepare to put the digit we have onto the end
5868 of the number so far. We check for overflows.
5872 n = u << shift; /* make room for the digit */
5873 if (!overflowed && (n >> shift) != u
5874 && !(PL_hints & HINT_NEW_BINARY)) {
5875 warn("Integer overflow in %s number",
5876 (shift == 4) ? "hex" : "octal");
5879 u = n | b; /* add the digit to the end */
5884 /* if we get here, we had success: make a scalar value from
5890 if ( PL_hints & HINT_NEW_BINARY)
5891 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5896 handle decimal numbers.
5897 we're also sent here when we read a 0 as the first digit
5899 case '1': case '2': case '3': case '4': case '5':
5900 case '6': case '7': case '8': case '9': case '.':
5903 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5906 /* read next group of digits and _ and copy into d */
5907 while (isDIGIT(*s) || *s == '_') {
5908 /* skip underscores, checking for misplaced ones
5912 if (PL_dowarn && lastub && s - lastub != 3)
5913 warn("Misplaced _ in number");
5917 /* check for end of fixed-length buffer */
5919 croak(number_too_long);
5920 /* if we're ok, copy the character */
5925 /* final misplaced underbar check */
5926 if (PL_dowarn && lastub && s - lastub != 3)
5927 warn("Misplaced _ in number");
5929 /* read a decimal portion if there is one. avoid
5930 3..5 being interpreted as the number 3. followed
5933 if (*s == '.' && s[1] != '.') {
5937 /* copy, ignoring underbars, until we run out of
5938 digits. Note: no misplaced underbar checks!
5940 for (; isDIGIT(*s) || *s == '_'; s++) {
5941 /* fixed length buffer check */
5943 croak(number_too_long);
5949 /* read exponent part, if present */
5950 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5954 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5955 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
5957 /* allow positive or negative exponent */
5958 if (*s == '+' || *s == '-')
5961 /* read digits of exponent (no underbars :-) */
5962 while (isDIGIT(*s)) {
5964 croak(number_too_long);
5969 /* terminate the string */
5972 /* make an sv from the string */
5974 /* reset numeric locale in case we were earlier left in Swaziland */
5975 SET_NUMERIC_STANDARD();
5976 value = atof(PL_tokenbuf);
5979 See if we can make do with an integer value without loss of
5980 precision. We use I_V to cast to an int, because some
5981 compilers have issues. Then we try casting it back and see
5982 if it was the same. We only do this if we know we
5983 specifically read an integer.
5985 Note: if floatit is true, then we don't need to do the
5989 if (!floatit && (double)tryiv == value)
5990 sv_setiv(sv, tryiv);
5992 sv_setnv(sv, value);
5993 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
5994 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
5995 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
5999 /* make the op for the constant and return */
6001 yylval.opval = newSVOP(OP_CONST, 0, sv);
6007 scan_formline(register char *s)
6012 SV *stuff = newSVpv("",0);
6013 bool needargs = FALSE;
6016 if (*s == '.' || *s == '}') {
6018 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
6022 if (PL_in_eval && !PL_rsfp) {
6023 eol = strchr(s,'\n');
6028 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6030 for (t = s; t < eol; t++) {
6031 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6033 goto enough; /* ~~ must be first line in formline */
6035 if (*t == '@' || *t == '^')
6038 sv_catpvn(stuff, s, eol-s);
6042 s = filter_gets(PL_linestr, PL_rsfp, 0);
6043 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6044 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6047 yyerror("Format not terminated");
6057 PL_lex_state = LEX_NORMAL;
6058 PL_nextval[PL_nexttoke].ival = 0;
6062 PL_lex_state = LEX_FORMLINE;
6063 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6065 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6069 SvREFCNT_dec(stuff);
6070 PL_lex_formbrack = 0;
6081 PL_cshlen = strlen(PL_cshname);
6086 start_subparse(I32 is_format, U32 flags)
6089 I32 oldsavestack_ix = PL_savestack_ix;
6090 CV* outsidecv = PL_compcv;
6094 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6096 save_I32(&PL_subline);
6097 save_item(PL_subname);
6099 SAVESPTR(PL_curpad);
6100 SAVESPTR(PL_comppad);
6101 SAVESPTR(PL_comppad_name);
6102 SAVESPTR(PL_compcv);
6103 SAVEI32(PL_comppad_name_fill);
6104 SAVEI32(PL_min_intro_pending);
6105 SAVEI32(PL_max_intro_pending);
6106 SAVEI32(PL_pad_reset_pending);
6108 PL_compcv = (CV*)NEWSV(1104,0);
6109 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6110 CvFLAGS(PL_compcv) |= flags;
6112 PL_comppad = newAV();
6113 av_push(PL_comppad, Nullsv);
6114 PL_curpad = AvARRAY(PL_comppad);
6115 PL_comppad_name = newAV();
6116 PL_comppad_name_fill = 0;
6117 PL_min_intro_pending = 0;
6119 PL_subline = PL_curcop->cop_line;
6121 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6122 PL_curpad[0] = (SV*)newAV();
6123 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6124 #endif /* USE_THREADS */
6126 comppadlist = newAV();
6127 AvREAL_off(comppadlist);
6128 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6129 av_store(comppadlist, 1, (SV*)PL_comppad);
6131 CvPADLIST(PL_compcv) = comppadlist;
6132 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6134 CvOWNER(PL_compcv) = 0;
6135 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6136 MUTEX_INIT(CvMUTEXP(PL_compcv));
6137 #endif /* USE_THREADS */
6139 return oldsavestack_ix;
6158 char *context = NULL;
6162 if (!yychar || (yychar == ';' && !PL_rsfp))
6164 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6165 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6166 while (isSPACE(*PL_oldoldbufptr))
6168 context = PL_oldoldbufptr;
6169 contlen = PL_bufptr - PL_oldoldbufptr;
6171 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6172 PL_oldbufptr != PL_bufptr) {
6173 while (isSPACE(*PL_oldbufptr))
6175 context = PL_oldbufptr;
6176 contlen = PL_bufptr - PL_oldbufptr;
6178 else if (yychar > 255)
6179 where = "next token ???";
6180 else if ((yychar & 127) == 127) {
6181 if (PL_lex_state == LEX_NORMAL ||
6182 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6183 where = "at end of line";
6184 else if (PL_lex_inpat)
6185 where = "within pattern";
6187 where = "within string";
6190 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6192 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6193 else if (isPRINT_LC(yychar))
6194 sv_catpvf(where_sv, "%c", yychar);
6196 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6197 where = SvPVX(where_sv);
6199 msg = sv_2mortal(newSVpv(s, 0));
6200 sv_catpvf(msg, " at %_ line %ld, ",
6201 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6203 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6205 sv_catpvf(msg, "%s\n", where);
6206 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6208 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6209 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6214 else if (PL_in_eval)
6215 sv_catsv(ERRSV, msg);
6217 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6218 if (++PL_error_count >= 10)
6219 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6221 PL_in_my_stash = Nullhv;