3 * Copyright (c) 1991-1997, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It all comes from here, the stench and the peril." --Frodo
18 static void check_uni _((void));
19 static void force_next _((I32 type));
20 static char *force_version _((char *start));
21 static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
22 static SV *tokeq _((SV *sv));
23 static char *scan_const _((char *start));
24 static char *scan_formline _((char *s));
25 static char *scan_heredoc _((char *s));
26 static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
28 static char *scan_inputsymbol _((char *start));
29 static char *scan_pat _((char *start, I32 type));
30 static char *scan_str _((char *start));
31 static char *scan_subst _((char *start));
32 static char *scan_trans _((char *start));
33 static char *scan_word _((char *s, char *dest, STRLEN destlen,
34 int allow_package, STRLEN *slp));
35 static char *skipspace _((char *s));
36 static void checkcomma _((char *s, char *name, char *what));
37 static void force_ident _((char *s, int kind));
38 static void incline _((char *s));
39 static int intuit_method _((char *s, GV *gv));
40 static int intuit_more _((char *s));
41 static I32 lop _((I32 f, expectation x, char *s));
42 static void missingterm _((char *s));
43 static void no_op _((char *what, char *s));
44 static void set_csh _((void));
45 static I32 sublex_done _((void));
46 static I32 sublex_push _((void));
47 static I32 sublex_start _((void));
49 static int uni _((I32 f, char *s));
51 static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
52 static void restore_rsfp _((void *f));
53 static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
54 static void restore_expect _((void *e));
55 static void restore_lex_expect _((void *e));
56 #endif /* PERL_OBJECT */
58 static char ident_too_long[] = "Identifier too long";
60 #define UTF (PL_hints & HINT_UTF8)
62 /* The following are arranged oddly so that the guard on the switch statement
63 * can get by with a single comparison (if the compiler is smart enough).
66 /* #define LEX_NOTPARSING 11 is done in perl.h. */
69 #define LEX_INTERPNORMAL 9
70 #define LEX_INTERPCASEMOD 8
71 #define LEX_INTERPPUSH 7
72 #define LEX_INTERPSTART 6
73 #define LEX_INTERPEND 5
74 #define LEX_INTERPENDMAYBE 4
75 #define LEX_INTERPCONCAT 3
76 #define LEX_INTERPCONST 2
77 #define LEX_FORMLINE 1
78 #define LEX_KNOWNEXT 0
87 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
89 # include <unistd.h> /* Needed for execv() */
102 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
104 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
105 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
106 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
107 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
108 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
109 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
110 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
111 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
112 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
113 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
114 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
115 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
116 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
117 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
118 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
119 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
120 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
121 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
122 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
123 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
125 /* This bit of chicanery makes a unary function followed by
126 * a parenthesis into a function with one argument, highest precedence.
128 #define UNI(f) return(yylval.ival = f, \
131 PL_last_uni = PL_oldbufptr, \
132 PL_last_lop_op = f, \
133 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
135 #define UNIBRACK(f) return(yylval.ival = f, \
137 PL_last_uni = PL_oldbufptr, \
138 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
140 /* grandfather return to old style */
141 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
146 if (*PL_bufptr == '=') {
148 if (toketype == ANDAND)
149 yylval.ival = OP_ANDASSIGN;
150 else if (toketype == OROR)
151 yylval.ival = OP_ORASSIGN;
158 no_op(char *what, char *s)
160 char *oldbp = PL_bufptr;
161 bool is_first = (PL_oldbufptr == PL_linestart);
164 yywarn(form("%s found where operator expected", what));
166 warn("\t(Missing semicolon on previous line?)\n");
167 else if (PL_oldoldbufptr && isIDFIRST(*PL_oldoldbufptr)) {
169 for (t = PL_oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
170 if (t < PL_bufptr && isSPACE(*t))
171 warn("\t(Do you need to predeclare %.*s?)\n",
172 t - PL_oldoldbufptr, PL_oldoldbufptr);
176 warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
186 char *nl = strrchr(s,'\n');
192 iscntrl(PL_multi_close)
194 PL_multi_close < 32 || PL_multi_close == 127
198 tmpbuf[1] = toCTRL(PL_multi_close);
204 *tmpbuf = PL_multi_close;
208 q = strchr(s,'"') ? '\'' : '"';
209 croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
216 if (ckWARN(WARN_DEPRECATED))
217 warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
223 deprecate("comma-less variable list");
229 win32_textfilter(int idx, SV *sv, int maxlen)
231 I32 count = FILTER_READ(idx+1, sv, maxlen);
232 if (count > 0 && !maxlen)
233 win32_strip_return(sv);
241 utf16_textfilter(int idx, SV *sv, int maxlen)
243 I32 count = FILTER_READ(idx+1, sv, maxlen);
247 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
248 tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
249 sv_usepvn(sv, (char*)tmps, tend - tmps);
256 utf16rev_textfilter(int idx, SV *sv, int maxlen)
258 I32 count = FILTER_READ(idx+1, sv, maxlen);
262 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
263 tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
264 sv_usepvn(sv, (char*)tmps, tend - tmps);
279 SAVEI32(PL_lex_dojoin);
280 SAVEI32(PL_lex_brackets);
281 SAVEI32(PL_lex_fakebrack);
282 SAVEI32(PL_lex_casemods);
283 SAVEI32(PL_lex_starts);
284 SAVEI32(PL_lex_state);
285 SAVESPTR(PL_lex_inpat);
286 SAVEI32(PL_lex_inwhat);
287 SAVEI16(PL_curcop->cop_line);
290 SAVEPPTR(PL_oldbufptr);
291 SAVEPPTR(PL_oldoldbufptr);
292 SAVEPPTR(PL_linestart);
293 SAVESPTR(PL_linestr);
294 SAVEPPTR(PL_lex_brackstack);
295 SAVEPPTR(PL_lex_casestack);
296 SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
297 SAVESPTR(PL_lex_stuff);
298 SAVEI32(PL_lex_defer);
299 SAVESPTR(PL_lex_repl);
300 SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
301 SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
303 PL_lex_state = LEX_NORMAL;
307 PL_lex_fakebrack = 0;
308 New(899, PL_lex_brackstack, 120, char);
309 New(899, PL_lex_casestack, 12, char);
310 SAVEFREEPV(PL_lex_brackstack);
311 SAVEFREEPV(PL_lex_casestack);
313 *PL_lex_casestack = '\0';
316 PL_lex_stuff = Nullsv;
317 PL_lex_repl = Nullsv;
321 if (SvREADONLY(PL_linestr))
322 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
323 s = SvPV(PL_linestr, len);
324 if (len && s[len-1] != ';') {
325 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
326 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
327 sv_catpvn(PL_linestr, "\n;", 2);
329 SvTEMP_off(PL_linestr);
330 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
331 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
333 PL_rs = newSVpv("\n", 1);
340 PL_doextract = FALSE;
344 restore_rsfp(void *f)
346 PerlIO *fp = (PerlIO*)f;
348 if (PL_rsfp == PerlIO_stdin())
349 PerlIO_clearerr(PL_rsfp);
350 else if (PL_rsfp && (PL_rsfp != fp))
351 PerlIO_close(PL_rsfp);
356 restore_expect(void *e)
358 /* a safe way to store a small integer in a pointer */
359 PL_expect = (expectation)((char *)e - PL_tokenbuf);
363 restore_lex_expect(void *e)
365 /* a safe way to store a small integer in a pointer */
366 PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
378 PL_curcop->cop_line++;
381 while (*s == ' ' || *s == '\t') s++;
382 if (strnEQ(s, "line ", 5)) {
391 while (*s == ' ' || *s == '\t')
393 if (*s == '"' && (t = strchr(s+1, '"')))
397 return; /* false alarm */
398 for (t = s; !isSPACE(*t); t++) ;
403 PL_curcop->cop_filegv = gv_fetchfile(s);
405 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
407 PL_curcop->cop_line = atoi(n)-1;
411 skipspace(register char *s)
414 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
415 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
421 while (s < PL_bufend && isSPACE(*s))
423 if (s < PL_bufend && *s == '#') {
424 while (s < PL_bufend && *s != '\n')
429 if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
431 if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
432 if (PL_minus_n || PL_minus_p) {
433 sv_setpv(PL_linestr,PL_minus_p ?
434 ";}continue{print or die qq(-p destination: $!\\n)" :
436 sv_catpv(PL_linestr,";}");
437 PL_minus_n = PL_minus_p = 0;
440 sv_setpv(PL_linestr,";");
441 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
442 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
443 if (PL_preprocess && !PL_in_eval)
444 (void)PerlProc_pclose(PL_rsfp);
445 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
446 PerlIO_clearerr(PL_rsfp);
448 (void)PerlIO_close(PL_rsfp);
452 PL_linestart = PL_bufptr = s + prevlen;
453 PL_bufend = s + SvCUR(PL_linestr);
456 if (PERLDB_LINE && PL_curstash != PL_debstash) {
457 SV *sv = NEWSV(85,0);
459 sv_upgrade(sv, SVt_PVMG);
460 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
461 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
472 if (PL_oldoldbufptr != PL_last_uni)
474 while (isSPACE(*PL_last_uni))
476 for (s = PL_last_uni; isALNUM(*s) || *s == '-'; s++) ;
477 if ((t = strchr(s, '(')) && t < PL_bufptr)
481 warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
488 #define UNI(f) return uni(f,s)
496 PL_last_uni = PL_oldbufptr;
507 #endif /* CRIPPLED_CC */
509 #define LOP(f,x) return lop(f,x,s)
512 lop(I32 f, expectation x, char *s)
519 PL_last_lop = PL_oldbufptr;
535 PL_nexttype[PL_nexttoke] = type;
537 if (PL_lex_state != LEX_KNOWNEXT) {
538 PL_lex_defer = PL_lex_state;
539 PL_lex_expect = PL_expect;
540 PL_lex_state = LEX_KNOWNEXT;
545 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
550 start = skipspace(start);
553 (allow_pack && *s == ':') ||
554 (allow_initial_tick && *s == '\'') )
556 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
557 if (check_keyword && keyword(PL_tokenbuf, len))
559 if (token == METHOD) {
564 PL_expect = XOPERATOR;
569 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
570 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
577 force_ident(register char *s, int kind)
580 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
581 PL_nextval[PL_nexttoke].opval = o;
584 dTHR; /* just for in_eval */
585 o->op_private = OPpCONST_ENTERED;
586 /* XXX see note in pp_entereval() for why we forgo typo
587 warnings if the symbol must be introduced in an eval.
589 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
590 kind == '$' ? SVt_PV :
591 kind == '@' ? SVt_PVAV :
592 kind == '%' ? SVt_PVHV :
600 force_version(char *s)
602 OP *version = Nullop;
606 /* default VERSION number -- GBARR */
611 for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
612 if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
614 /* real VERSION number -- GBARR */
615 version = yylval.opval;
619 /* NOTE: The parser sees the package name and the VERSION swapped */
620 PL_nextval[PL_nexttoke].opval = version;
638 s = SvPV_force(sv, len);
642 while (s < send && *s != '\\')
647 if ( PL_hints & HINT_NEW_STRING )
648 pv = sv_2mortal(newSVpv(SvPVX(pv), len));
651 if (s + 1 < send && (s[1] == '\\'))
652 s++; /* all that, just for this */
657 SvCUR_set(sv, d - SvPVX(sv));
659 if ( PL_hints & HINT_NEW_STRING )
660 return new_constant(NULL, 0, "q", sv, pv, "q");
667 register I32 op_type = yylval.ival;
669 if (op_type == OP_NULL) {
670 yylval.opval = PL_lex_op;
674 if (op_type == OP_CONST || op_type == OP_READLINE) {
675 SV *sv = tokeq(PL_lex_stuff);
677 if (SvTYPE(sv) == SVt_PVIV) {
678 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
684 nsv = newSVpv(p, len);
688 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
689 PL_lex_stuff = Nullsv;
693 PL_sublex_info.super_state = PL_lex_state;
694 PL_sublex_info.sub_inwhat = op_type;
695 PL_sublex_info.sub_op = PL_lex_op;
696 PL_lex_state = LEX_INTERPPUSH;
700 yylval.opval = PL_lex_op;
714 PL_lex_state = PL_sublex_info.super_state;
715 SAVEI32(PL_lex_dojoin);
716 SAVEI32(PL_lex_brackets);
717 SAVEI32(PL_lex_fakebrack);
718 SAVEI32(PL_lex_casemods);
719 SAVEI32(PL_lex_starts);
720 SAVEI32(PL_lex_state);
721 SAVESPTR(PL_lex_inpat);
722 SAVEI32(PL_lex_inwhat);
723 SAVEI16(PL_curcop->cop_line);
725 SAVEPPTR(PL_oldbufptr);
726 SAVEPPTR(PL_oldoldbufptr);
727 SAVEPPTR(PL_linestart);
728 SAVESPTR(PL_linestr);
729 SAVEPPTR(PL_lex_brackstack);
730 SAVEPPTR(PL_lex_casestack);
732 PL_linestr = PL_lex_stuff;
733 PL_lex_stuff = Nullsv;
735 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
736 PL_bufend += SvCUR(PL_linestr);
737 SAVEFREESV(PL_linestr);
739 PL_lex_dojoin = FALSE;
741 PL_lex_fakebrack = 0;
742 New(899, PL_lex_brackstack, 120, char);
743 New(899, PL_lex_casestack, 12, char);
744 SAVEFREEPV(PL_lex_brackstack);
745 SAVEFREEPV(PL_lex_casestack);
747 *PL_lex_casestack = '\0';
749 PL_lex_state = LEX_INTERPCONCAT;
750 PL_curcop->cop_line = PL_multi_start;
752 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
753 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
754 PL_lex_inpat = PL_sublex_info.sub_op;
756 PL_lex_inpat = Nullop;
764 if (!PL_lex_starts++) {
765 PL_expect = XOPERATOR;
766 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
770 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
771 PL_lex_state = LEX_INTERPCASEMOD;
775 /* Is there a right-hand side to take care of? */
776 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
777 PL_linestr = PL_lex_repl;
779 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
780 PL_bufend += SvCUR(PL_linestr);
781 SAVEFREESV(PL_linestr);
782 PL_lex_dojoin = FALSE;
784 PL_lex_fakebrack = 0;
786 *PL_lex_casestack = '\0';
788 if (SvCOMPILED(PL_lex_repl)) {
789 PL_lex_state = LEX_INTERPNORMAL;
793 PL_lex_state = LEX_INTERPCONCAT;
794 PL_lex_repl = Nullsv;
799 PL_bufend = SvPVX(PL_linestr);
800 PL_bufend += SvCUR(PL_linestr);
801 PL_expect = XOPERATOR;
809 Extracts a pattern, double-quoted string, or transliteration. This
812 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
813 processing a pattern (PL_lex_inpat is true), a transliteration
814 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
816 Returns a pointer to the character scanned up to. Iff this is
817 advanced from the start pointer supplied (ie if anything was
818 successfully parsed), will leave an OP for the substring scanned
819 in yylval. Caller must intuit reason for not parsing further
820 by looking at the next characters herself.
824 double-quoted style: \r and \n
825 regexp special ones: \D \s
827 backrefs: \1 (deprecated in substitution replacements)
828 case and quoting: \U \Q \E
829 stops on @ and $, but not for $ as tail anchor
832 characters are VERY literal, except for - not at the start or end
833 of the string, which indicates a range. scan_const expands the
834 range to the full set of intermediate characters.
836 In double-quoted strings:
838 double-quoted style: \r and \n
840 backrefs: \1 (deprecated)
841 case and quoting: \U \Q \E
844 scan_const does *not* construct ops to handle interpolated strings.
845 It stops processing as soon as it finds an embedded $ or @ variable
846 and leaves it to the caller to work out what's going on.
848 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
850 $ in pattern could be $foo or could be tail anchor. Assumption:
851 it's a tail anchor if $ is the last thing in the string, or if it's
852 followed by one of ")| \n\t"
854 \1 (backreferences) are turned into $1
856 The structure of the code is
857 while (there's a character to process) {
858 handle transliteration ranges
860 skip # initiated comments in //x patterns
861 check for embedded @foo
862 check for embedded scalars
864 leave intact backslashes from leave (below)
865 deprecate \1 in strings and sub replacements
866 handle string-changing backslashes \l \U \Q \E, etc.
867 switch (what was escaped) {
868 handle - in a transliteration (becomes a literal -)
869 handle \132 octal characters
870 handle 0x15 hex characters
871 handle \cV (control V)
872 handle printf backslashes (\f, \r, \n, etc)
875 } (end while character to read)
880 scan_const(char *start)
882 register char *send = PL_bufend; /* end of the constant */
883 SV *sv = NEWSV(93, send - start); /* sv for the constant */
884 register char *s = start; /* start of the constant */
885 register char *d = SvPVX(sv); /* destination for copies */
886 bool dorange = FALSE; /* are we in a translit range? */
888 I32 utf = PL_lex_inwhat == OP_TRANS
889 ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
891 I32 thisutf = PL_lex_inwhat == OP_TRANS
892 ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
895 /* leaveit is the set of acceptably-backslashed characters */
898 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
901 while (s < send || dorange) {
902 /* get transliterations out of the way (they're most literal) */
903 if (PL_lex_inwhat == OP_TRANS) {
904 /* expand a range A-Z to the full set of characters. AIE! */
906 I32 i; /* current expanded character */
907 I32 max; /* last character in range */
909 i = d - SvPVX(sv); /* remember current offset */
910 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
911 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
912 d -= 2; /* eat the first char and the - */
914 max = (U8)d[1]; /* last char in range */
916 for (i = (U8)*d; i <= max; i++)
919 /* mark the range as done, and continue */
924 /* range begins (ignore - as first or last char) */
925 else if (*s == '-' && s+1 < send && s != start) {
927 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
936 /* if we get here, we're not doing a transliteration */
938 /* skip for regexp comments /(?#comment)/ */
939 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
941 while (s < send && *s != ')')
943 } else if (s[2] == '{') { /* This should march regcomp.c */
945 char *regparse = s + 3;
948 while (count && (c = *regparse)) {
949 if (c == '\\' && regparse[1])
957 if (*regparse == ')')
960 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
961 while (s < regparse && *s != ')')
966 /* likewise skip #-initiated comments in //x patterns */
967 else if (*s == '#' && PL_lex_inpat &&
968 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
969 while (s+1 < send && *s != '\n')
973 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
974 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
977 /* check for embedded scalars. only stop if we're sure it's a
980 else if (*s == '$') {
981 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
983 if (s + 1 < send && !strchr("()| \n\t", s[1]))
984 break; /* in regexp, $ might be tail anchor */
987 /* (now in tr/// code again) */
989 if (*s & 0x80 && thisutf) {
990 dTHR; /* only for ckWARN */
991 if (ckWARN(WARN_UTF8)) {
992 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1002 if (*s == '\\' && s+1 < send) {
1005 /* some backslashes we leave behind */
1006 if (*s && strchr(leaveit, *s)) {
1012 /* deprecate \1 in strings and substitution replacements */
1013 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1014 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1016 dTHR; /* only for ckWARN */
1017 if (ckWARN(WARN_SYNTAX))
1018 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1023 /* string-change backslash escapes */
1024 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1029 /* if we get here, it's either a quoted -, or a digit */
1032 /* quoted - in transliterations */
1034 if (PL_lex_inwhat == OP_TRANS) {
1039 /* default action is to copy the quoted character */
1044 /* \132 indicates an octal constant */
1045 case '0': case '1': case '2': case '3':
1046 case '4': case '5': case '6': case '7':
1047 *d++ = scan_oct(s, 3, &len);
1051 /* \x24 indicates a hex constant */
1055 char* e = strchr(s, '}');
1058 yyerror("Missing right brace on \\x{}");
1061 if (ckWARN(WARN_UTF8))
1063 "Use of \\x{} without utf8 declaration");
1065 /* note: utf always shorter than hex */
1066 d = (char*)uv_to_utf8((U8*)d,
1067 scan_hex(s + 1, e - s - 1, &len));
1072 UV uv = (UV)scan_hex(s, 2, &len);
1073 if (utf && PL_lex_inwhat == OP_TRANS &&
1074 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1076 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1079 if (uv >= 127 && UTF) {
1081 if (ckWARN(WARN_UTF8))
1083 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1092 /* \c is a control character */
1106 /* printf-style backslashes, formfeeds, newlines, etc */
1132 } /* end if (backslash) */
1135 } /* while loop to process each character */
1137 /* terminate the string and set up the sv */
1139 SvCUR_set(sv, d - SvPVX(sv));
1142 /* shrink the sv if we allocated more than we used */
1143 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1144 SvLEN_set(sv, SvCUR(sv) + 1);
1145 Renew(SvPVX(sv), SvLEN(sv), char);
1148 /* return the substring (via yylval) only if we parsed anything */
1149 if (s > PL_bufptr) {
1150 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1151 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1153 ( PL_lex_inwhat == OP_TRANS
1155 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1158 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1164 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1166 intuit_more(register char *s)
1168 if (PL_lex_brackets)
1170 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1172 if (*s != '{' && *s != '[')
1177 /* In a pattern, so maybe we have {n,m}. */
1194 /* On the other hand, maybe we have a character class */
1197 if (*s == ']' || *s == '^')
1200 int weight = 2; /* let's weigh the evidence */
1202 unsigned char un_char = 255, last_un_char;
1203 char *send = strchr(s,']');
1204 char tmpbuf[sizeof PL_tokenbuf * 4];
1206 if (!send) /* has to be an expression */
1209 Zero(seen,256,char);
1212 else if (isDIGIT(*s)) {
1214 if (isDIGIT(s[1]) && s[2] == ']')
1220 for (; s < send; s++) {
1221 last_un_char = un_char;
1222 un_char = (unsigned char)*s;
1227 weight -= seen[un_char] * 10;
1228 if (isALNUM(s[1])) {
1229 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1230 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1235 else if (*s == '$' && s[1] &&
1236 strchr("[#!%*<>()-=",s[1])) {
1237 if (/*{*/ strchr("])} =",s[2]))
1246 if (strchr("wds]",s[1]))
1248 else if (seen['\''] || seen['"'])
1250 else if (strchr("rnftbxcav",s[1]))
1252 else if (isDIGIT(s[1])) {
1254 while (s[1] && isDIGIT(s[1]))
1264 if (strchr("aA01! ",last_un_char))
1266 if (strchr("zZ79~",s[1]))
1268 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1269 weight -= 5; /* cope with negative subscript */
1272 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1273 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1278 if (keyword(tmpbuf, d - tmpbuf))
1281 if (un_char == last_un_char + 1)
1283 weight -= seen[un_char];
1288 if (weight >= 0) /* probably a character class */
1296 intuit_method(char *start, GV *gv)
1298 char *s = start + (*start == '$');
1299 char tmpbuf[sizeof PL_tokenbuf];
1307 if ((cv = GvCVu(gv))) {
1308 char *proto = SvPVX(cv);
1318 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1319 if (*start == '$') {
1320 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1325 return *s == '(' ? FUNCMETH : METHOD;
1327 if (!keyword(tmpbuf, len)) {
1328 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1333 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1334 if (indirgv && GvCVu(indirgv))
1336 /* filehandle or package name makes it a method */
1337 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1339 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1340 return 0; /* no assumptions -- "=>" quotes bearword */
1342 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1344 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1348 return *s == '(' ? FUNCMETH : METHOD;
1358 char *pdb = PerlEnv_getenv("PERL5DB");
1362 SETERRNO(0,SS$_NORMAL);
1363 return "BEGIN { require 'perl5db.pl' }";
1369 /* Encoded script support. filter_add() effectively inserts a
1370 * 'pre-processing' function into the current source input stream.
1371 * Note that the filter function only applies to the current source file
1372 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1374 * The datasv parameter (which may be NULL) can be used to pass
1375 * private data to this instance of the filter. The filter function
1376 * can recover the SV using the FILTER_DATA macro and use it to
1377 * store private buffers and state information.
1379 * The supplied datasv parameter is upgraded to a PVIO type
1380 * and the IoDIRP field is used to store the function pointer.
1381 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1382 * private use must be set using malloc'd pointers.
1384 static int filter_debug = 0;
1387 filter_add(filter_t funcp, SV *datasv)
1389 if (!funcp){ /* temporary handy debugging hack to be deleted */
1390 filter_debug = atoi((char*)datasv);
1393 if (!PL_rsfp_filters)
1394 PL_rsfp_filters = newAV();
1396 datasv = NEWSV(255,0);
1397 if (!SvUPGRADE(datasv, SVt_PVIO))
1398 die("Can't upgrade filter_add data to SVt_PVIO");
1399 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1401 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1402 av_unshift(PL_rsfp_filters, 1);
1403 av_store(PL_rsfp_filters, 0, datasv) ;
1408 /* Delete most recently added instance of this filter function. */
1410 filter_del(filter_t funcp)
1413 warn("filter_del func %p", funcp);
1414 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1416 /* if filter is on top of stack (usual case) just pop it off */
1417 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (void*)funcp){
1418 sv_free(av_pop(PL_rsfp_filters));
1422 /* we need to search for the correct entry and clear it */
1423 die("filter_del can only delete in reverse order (currently)");
1427 /* Invoke the n'th filter function for the current rsfp. */
1429 filter_read(int idx, SV *buf_sv, int maxlen)
1432 /* 0 = read one text line */
1437 if (!PL_rsfp_filters)
1439 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1440 /* Provide a default input filter to make life easy. */
1441 /* Note that we append to the line. This is handy. */
1443 warn("filter_read %d: from rsfp\n", idx);
1447 int old_len = SvCUR(buf_sv) ;
1449 /* ensure buf_sv is large enough */
1450 SvGROW(buf_sv, old_len + maxlen) ;
1451 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1452 if (PerlIO_error(PL_rsfp))
1453 return -1; /* error */
1455 return 0 ; /* end of file */
1457 SvCUR_set(buf_sv, old_len + len) ;
1460 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1461 if (PerlIO_error(PL_rsfp))
1462 return -1; /* error */
1464 return 0 ; /* end of file */
1467 return SvCUR(buf_sv);
1469 /* Skip this filter slot if filter has been deleted */
1470 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1472 warn("filter_read %d: skipped (filter deleted)\n", idx);
1473 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1475 /* Get function pointer hidden within datasv */
1476 funcp = (filter_t)IoDIRP(datasv);
1478 warn("filter_read %d: via function %p (%s)\n",
1479 idx, funcp, SvPV(datasv,PL_na));
1480 /* Call function. The function is expected to */
1481 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1482 /* Return: <0:error, =0:eof, >0:not eof */
1483 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1487 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1490 if (!PL_rsfp_filters) {
1491 filter_add(win32_textfilter,NULL);
1494 if (PL_rsfp_filters) {
1497 SvCUR_set(sv, 0); /* start with empty line */
1498 if (FILTER_READ(0, sv, 0) > 0)
1499 return ( SvPVX(sv) ) ;
1504 return (sv_gets(sv, fp, append));
1509 static char* exp_name[] =
1510 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1513 EXT int yychar; /* last token */
1518 Works out what to call the token just pulled out of the input
1519 stream. The yacc parser takes care of taking the ops we return and
1520 stitching them into a tree.
1526 if read an identifier
1527 if we're in a my declaration
1528 croak if they tried to say my($foo::bar)
1529 build the ops for a my() declaration
1530 if it's an access to a my() variable
1531 are we in a sort block?
1532 croak if my($a); $a <=> $b
1533 build ops for access to a my() variable
1534 if in a dq string, and they've said @foo and we can't find @foo
1536 build ops for a bareword
1537 if we already built the token before, use it.
1551 /* check if there's an identifier for us to look at */
1552 if (PL_pending_ident) {
1553 /* pit holds the identifier we read and pending_ident is reset */
1554 char pit = PL_pending_ident;
1555 PL_pending_ident = 0;
1557 /* if we're in a my(), we can't allow dynamics here.
1558 $foo'bar has already been turned into $foo::bar, so
1559 just check for colons.
1561 if it's a legal name, the OP is a PADANY.
1564 if (strchr(PL_tokenbuf,':'))
1565 croak(no_myglob,PL_tokenbuf);
1567 yylval.opval = newOP(OP_PADANY, 0);
1568 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1573 build the ops for accesses to a my() variable.
1575 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1576 then used in a comparison. This catches most, but not
1577 all cases. For instance, it catches
1578 sort { my($a); $a <=> $b }
1580 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1581 (although why you'd do that is anyone's guess).
1584 if (!strchr(PL_tokenbuf,':')) {
1586 /* Check for single character per-thread SVs */
1587 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1588 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1589 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1591 yylval.opval = newOP(OP_THREADSV, 0);
1592 yylval.opval->op_targ = tmp;
1595 #endif /* USE_THREADS */
1596 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1597 /* if it's a sort block and they're naming $a or $b */
1598 if (PL_last_lop_op == OP_SORT &&
1599 PL_tokenbuf[0] == '$' &&
1600 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1603 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1604 d < PL_bufend && *d != '\n';
1607 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1608 croak("Can't use \"my %s\" in sort comparison",
1614 yylval.opval = newOP(OP_PADANY, 0);
1615 yylval.opval->op_targ = tmp;
1621 Whine if they've said @foo in a doublequoted string,
1622 and @foo isn't a variable we can find in the symbol
1625 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1626 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1627 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1628 yyerror(form("In string, %s now must be written as \\%s",
1629 PL_tokenbuf, PL_tokenbuf));
1632 /* build ops for a bareword */
1633 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1634 yylval.opval->op_private = OPpCONST_ENTERED;
1635 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1636 ((PL_tokenbuf[0] == '$') ? SVt_PV
1637 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1642 /* no identifier pending identification */
1644 switch (PL_lex_state) {
1646 case LEX_NORMAL: /* Some compilers will produce faster */
1647 case LEX_INTERPNORMAL: /* code if we comment these out. */
1651 /* when we're already built the next token, just pull it out the queue */
1654 yylval = PL_nextval[PL_nexttoke];
1656 PL_lex_state = PL_lex_defer;
1657 PL_expect = PL_lex_expect;
1658 PL_lex_defer = LEX_NORMAL;
1660 return(PL_nexttype[PL_nexttoke]);
1662 /* interpolated case modifiers like \L \U, including \Q and \E.
1663 when we get here, PL_bufptr is at the \
1665 case LEX_INTERPCASEMOD:
1667 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1668 croak("panic: INTERPCASEMOD");
1670 /* handle \E or end of string */
1671 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1675 if (PL_lex_casemods) {
1676 oldmod = PL_lex_casestack[--PL_lex_casemods];
1677 PL_lex_casestack[PL_lex_casemods] = '\0';
1679 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1681 PL_lex_state = LEX_INTERPCONCAT;
1685 if (PL_bufptr != PL_bufend)
1687 PL_lex_state = LEX_INTERPCONCAT;
1692 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1693 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1694 if (strchr("LU", *s) &&
1695 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1697 PL_lex_casestack[--PL_lex_casemods] = '\0';
1700 if (PL_lex_casemods > 10) {
1701 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1702 if (newlb != PL_lex_casestack) {
1704 PL_lex_casestack = newlb;
1707 PL_lex_casestack[PL_lex_casemods++] = *s;
1708 PL_lex_casestack[PL_lex_casemods] = '\0';
1709 PL_lex_state = LEX_INTERPCONCAT;
1710 PL_nextval[PL_nexttoke].ival = 0;
1713 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1715 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1717 PL_nextval[PL_nexttoke].ival = OP_LC;
1719 PL_nextval[PL_nexttoke].ival = OP_UC;
1721 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1723 croak("panic: yylex");
1726 if (PL_lex_starts) {
1735 case LEX_INTERPPUSH:
1736 return sublex_push();
1738 case LEX_INTERPSTART:
1739 if (PL_bufptr == PL_bufend)
1740 return sublex_done();
1742 PL_lex_dojoin = (*PL_bufptr == '@');
1743 PL_lex_state = LEX_INTERPNORMAL;
1744 if (PL_lex_dojoin) {
1745 PL_nextval[PL_nexttoke].ival = 0;
1748 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1749 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1750 force_next(PRIVATEREF);
1752 force_ident("\"", '$');
1753 #endif /* USE_THREADS */
1754 PL_nextval[PL_nexttoke].ival = 0;
1756 PL_nextval[PL_nexttoke].ival = 0;
1758 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1761 if (PL_lex_starts++) {
1767 case LEX_INTERPENDMAYBE:
1768 if (intuit_more(PL_bufptr)) {
1769 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1775 if (PL_lex_dojoin) {
1776 PL_lex_dojoin = FALSE;
1777 PL_lex_state = LEX_INTERPCONCAT;
1781 case LEX_INTERPCONCAT:
1783 if (PL_lex_brackets)
1784 croak("panic: INTERPCONCAT");
1786 if (PL_bufptr == PL_bufend)
1787 return sublex_done();
1789 if (SvIVX(PL_linestr) == '\'') {
1790 SV *sv = newSVsv(PL_linestr);
1793 else if ( PL_hints & HINT_NEW_RE )
1794 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1795 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1799 s = scan_const(PL_bufptr);
1801 PL_lex_state = LEX_INTERPCASEMOD;
1803 PL_lex_state = LEX_INTERPSTART;
1806 if (s != PL_bufptr) {
1807 PL_nextval[PL_nexttoke] = yylval;
1810 if (PL_lex_starts++)
1820 PL_lex_state = LEX_NORMAL;
1821 s = scan_formline(PL_bufptr);
1822 if (!PL_lex_formbrack)
1828 PL_oldoldbufptr = PL_oldbufptr;
1831 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1838 * Note: we try to be careful never to call the isXXX_utf8() functions unless we're
1839 * pretty sure we've seen the beginning of a UTF-8 character (that is, the two high
1840 * bits are set). Otherwise we risk loading in the heavy-duty SWASHINIT and SWASHGET
1841 * routines unnecessarily. You will see this not just here but throughout this file.
1843 if (UTF && (*s & 0xc0) == 0x80) {
1844 if (isIDFIRST_utf8((U8*)s))
1847 croak("Unrecognized character \\x%02X", *s & 255);
1850 goto fake_eof; /* emulate EOF on ^D or ^Z */
1855 if (PL_lex_brackets)
1856 yyerror("Missing right bracket");
1859 if (s++ < PL_bufend)
1860 goto retry; /* ignore stray nulls */
1863 if (!PL_in_eval && !PL_preambled) {
1864 PL_preambled = TRUE;
1865 sv_setpv(PL_linestr,incl_perldb());
1866 if (SvCUR(PL_linestr))
1867 sv_catpv(PL_linestr,";");
1869 while(AvFILLp(PL_preambleav) >= 0) {
1870 SV *tmpsv = av_shift(PL_preambleav);
1871 sv_catsv(PL_linestr, tmpsv);
1872 sv_catpv(PL_linestr, ";");
1875 sv_free((SV*)PL_preambleav);
1876 PL_preambleav = NULL;
1878 if (PL_minus_n || PL_minus_p) {
1879 sv_catpv(PL_linestr, "LINE: while (<>) {");
1881 sv_catpv(PL_linestr,"chomp;");
1883 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1885 GvIMPORTED_AV_on(gv);
1887 if (strchr("/'\"", *PL_splitstr)
1888 && strchr(PL_splitstr + 1, *PL_splitstr))
1889 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1892 s = "'~#\200\1'"; /* surely one char is unused...*/
1893 while (s[1] && strchr(PL_splitstr, *s)) s++;
1895 sv_catpvf(PL_linestr, "@F=split(%s%c",
1896 "q" + (delim == '\''), delim);
1897 for (s = PL_splitstr; *s; s++) {
1899 sv_catpvn(PL_linestr, "\\", 1);
1900 sv_catpvn(PL_linestr, s, 1);
1902 sv_catpvf(PL_linestr, "%c);", delim);
1906 sv_catpv(PL_linestr,"@F=split(' ');");
1909 sv_catpv(PL_linestr, "\n");
1910 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1911 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1912 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1913 SV *sv = NEWSV(85,0);
1915 sv_upgrade(sv, SVt_PVMG);
1916 sv_setsv(sv,PL_linestr);
1917 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1922 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1925 if (PL_preprocess && !PL_in_eval)
1926 (void)PerlProc_pclose(PL_rsfp);
1927 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1928 PerlIO_clearerr(PL_rsfp);
1930 (void)PerlIO_close(PL_rsfp);
1932 PL_doextract = FALSE;
1934 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1935 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1936 sv_catpv(PL_linestr,";}");
1937 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1938 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1939 PL_minus_n = PL_minus_p = 0;
1942 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1943 sv_setpv(PL_linestr,"");
1944 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1947 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1948 PL_doextract = FALSE;
1950 /* Incest with pod. */
1951 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1952 sv_setpv(PL_linestr, "");
1953 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1954 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1955 PL_doextract = FALSE;
1959 } while (PL_doextract);
1960 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1961 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1962 SV *sv = NEWSV(85,0);
1964 sv_upgrade(sv, SVt_PVMG);
1965 sv_setsv(sv,PL_linestr);
1966 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1968 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1969 if (PL_curcop->cop_line == 1) {
1970 while (s < PL_bufend && isSPACE(*s))
1972 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1976 if (*s == '#' && *(s+1) == '!')
1978 #ifdef ALTERNATE_SHEBANG
1980 static char as[] = ALTERNATE_SHEBANG;
1981 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1982 d = s + (sizeof(as) - 1);
1984 #endif /* ALTERNATE_SHEBANG */
1993 while (*d && !isSPACE(*d))
1997 #ifdef ARG_ZERO_IS_SCRIPT
1998 if (ipathend > ipath) {
2000 * HP-UX (at least) sets argv[0] to the script name,
2001 * which makes $^X incorrect. And Digital UNIX and Linux,
2002 * at least, set argv[0] to the basename of the Perl
2003 * interpreter. So, having found "#!", we'll set it right.
2005 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2006 assert(SvPOK(x) || SvGMAGICAL(x));
2007 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2008 sv_setpvn(x, ipath, ipathend - ipath);
2011 TAINT_NOT; /* $^X is always tainted, but that's OK */
2013 #endif /* ARG_ZERO_IS_SCRIPT */
2018 d = instr(s,"perl -");
2020 d = instr(s,"perl");
2021 #ifdef ALTERNATE_SHEBANG
2023 * If the ALTERNATE_SHEBANG on this system starts with a
2024 * character that can be part of a Perl expression, then if
2025 * we see it but not "perl", we're probably looking at the
2026 * start of Perl code, not a request to hand off to some
2027 * other interpreter. Similarly, if "perl" is there, but
2028 * not in the first 'word' of the line, we assume the line
2029 * contains the start of the Perl program.
2031 if (d && *s != '#') {
2033 while (*c && !strchr("; \t\r\n\f\v#", *c))
2036 d = Nullch; /* "perl" not in first word; ignore */
2038 *s = '#'; /* Don't try to parse shebang line */
2040 #endif /* ALTERNATE_SHEBANG */
2045 !instr(s,"indir") &&
2046 instr(PL_origargv[0],"perl"))
2052 while (s < PL_bufend && isSPACE(*s))
2054 if (s < PL_bufend) {
2055 Newz(899,newargv,PL_origargc+3,char*);
2057 while (s < PL_bufend && !isSPACE(*s))
2060 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2063 newargv = PL_origargv;
2065 execv(ipath, newargv);
2066 croak("Can't exec %s", ipath);
2069 U32 oldpdb = PL_perldb;
2070 bool oldn = PL_minus_n;
2071 bool oldp = PL_minus_p;
2073 while (*d && !isSPACE(*d)) d++;
2074 while (*d == ' ' || *d == '\t') d++;
2078 if (*d == 'M' || *d == 'm') {
2080 while (*d && !isSPACE(*d)) d++;
2081 croak("Too late for \"-%.*s\" option",
2084 d = moreswitches(d);
2086 if (PERLDB_LINE && !oldpdb ||
2087 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2088 /* if we have already added "LINE: while (<>) {",
2089 we must not do it again */
2091 sv_setpv(PL_linestr, "");
2092 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2093 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2094 PL_preambled = FALSE;
2096 (void)gv_fetchfile(PL_origfilename);
2103 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2105 PL_lex_state = LEX_FORMLINE;
2110 #ifdef PERL_STRICT_CR
2111 warn("Illegal character \\%03o (carriage return)", '\r');
2113 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2115 case ' ': case '\t': case '\f': case 013:
2120 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2122 while (s < d && *s != '\n')
2127 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2129 PL_lex_state = LEX_FORMLINE;
2139 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2144 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2147 if (strnEQ(s,"=>",2)) {
2148 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2149 OPERATOR('-'); /* unary minus */
2151 PL_last_uni = PL_oldbufptr;
2152 PL_last_lop_op = OP_FTEREAD; /* good enough */
2154 case 'r': FTST(OP_FTEREAD);
2155 case 'w': FTST(OP_FTEWRITE);
2156 case 'x': FTST(OP_FTEEXEC);
2157 case 'o': FTST(OP_FTEOWNED);
2158 case 'R': FTST(OP_FTRREAD);
2159 case 'W': FTST(OP_FTRWRITE);
2160 case 'X': FTST(OP_FTREXEC);
2161 case 'O': FTST(OP_FTROWNED);
2162 case 'e': FTST(OP_FTIS);
2163 case 'z': FTST(OP_FTZERO);
2164 case 's': FTST(OP_FTSIZE);
2165 case 'f': FTST(OP_FTFILE);
2166 case 'd': FTST(OP_FTDIR);
2167 case 'l': FTST(OP_FTLINK);
2168 case 'p': FTST(OP_FTPIPE);
2169 case 'S': FTST(OP_FTSOCK);
2170 case 'u': FTST(OP_FTSUID);
2171 case 'g': FTST(OP_FTSGID);
2172 case 'k': FTST(OP_FTSVTX);
2173 case 'b': FTST(OP_FTBLK);
2174 case 'c': FTST(OP_FTCHR);
2175 case 't': FTST(OP_FTTTY);
2176 case 'T': FTST(OP_FTTEXT);
2177 case 'B': FTST(OP_FTBINARY);
2178 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2179 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2180 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2182 croak("Unrecognized file test: -%c", (int)tmp);
2189 if (PL_expect == XOPERATOR)
2194 else if (*s == '>') {
2197 if (isIDFIRST(*s)) {
2198 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2206 if (PL_expect == XOPERATOR)
2209 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2211 OPERATOR('-'); /* unary minus */
2218 if (PL_expect == XOPERATOR)
2223 if (PL_expect == XOPERATOR)
2226 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2232 if (PL_expect != XOPERATOR) {
2233 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2234 PL_expect = XOPERATOR;
2235 force_ident(PL_tokenbuf, '*');
2248 if (PL_expect == XOPERATOR) {
2252 PL_tokenbuf[0] = '%';
2253 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2254 if (!PL_tokenbuf[1]) {
2256 yyerror("Final % should be \\% or %name");
2259 PL_pending_ident = '%';
2281 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2282 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2287 if (PL_curcop->cop_line < PL_copline)
2288 PL_copline = PL_curcop->cop_line;
2299 if (PL_lex_brackets <= 0)
2300 yyerror("Unmatched right bracket");
2303 if (PL_lex_state == LEX_INTERPNORMAL) {
2304 if (PL_lex_brackets == 0) {
2305 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2306 PL_lex_state = LEX_INTERPEND;
2313 if (PL_lex_brackets > 100) {
2314 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2315 if (newlb != PL_lex_brackstack) {
2317 PL_lex_brackstack = newlb;
2320 switch (PL_expect) {
2322 if (PL_lex_formbrack) {
2326 if (PL_oldoldbufptr == PL_last_lop)
2327 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2329 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2330 OPERATOR(HASHBRACK);
2332 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2335 PL_tokenbuf[0] = '\0';
2336 if (d < PL_bufend && *d == '-') {
2337 PL_tokenbuf[0] = '-';
2339 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2342 if (d < PL_bufend && isIDFIRST(*d)) {
2343 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2345 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2348 char minus = (PL_tokenbuf[0] == '-');
2349 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2356 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2360 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2365 if (PL_oldoldbufptr == PL_last_lop)
2366 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2368 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2371 OPERATOR(HASHBRACK);
2372 /* This hack serves to disambiguate a pair of curlies
2373 * as being a block or an anon hash. Normally, expectation
2374 * determines that, but in cases where we're not in a
2375 * position to expect anything in particular (like inside
2376 * eval"") we have to resolve the ambiguity. This code
2377 * covers the case where the first term in the curlies is a
2378 * quoted string. Most other cases need to be explicitly
2379 * disambiguated by prepending a `+' before the opening
2380 * curly in order to force resolution as an anon hash.
2382 * XXX should probably propagate the outer expectation
2383 * into eval"" to rely less on this hack, but that could
2384 * potentially break current behavior of eval"".
2388 if (*s == '\'' || *s == '"' || *s == '`') {
2389 /* common case: get past first string, handling escapes */
2390 for (t++; t < PL_bufend && *t != *s;)
2391 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2395 else if (*s == 'q') {
2398 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2399 && !isALNUM(*t)))) {
2401 char open, close, term;
2404 while (t < PL_bufend && isSPACE(*t))
2408 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2412 for (t++; t < PL_bufend; t++) {
2413 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2415 else if (*t == open)
2419 for (t++; t < PL_bufend; t++) {
2420 if (*t == '\\' && t+1 < PL_bufend)
2422 else if (*t == close && --brackets <= 0)
2424 else if (*t == open)
2430 else if (isALPHA(*s)) {
2431 for (t++; t < PL_bufend && isALNUM(*t); t++) ;
2433 while (t < PL_bufend && isSPACE(*t))
2435 /* if comma follows first term, call it an anon hash */
2436 /* XXX it could be a comma expression with loop modifiers */
2437 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2438 || (*t == '=' && t[1] == '>')))
2439 OPERATOR(HASHBRACK);
2440 if (PL_expect == XREF)
2443 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2449 yylval.ival = PL_curcop->cop_line;
2450 if (isSPACE(*s) || *s == '#')
2451 PL_copline = NOLINE; /* invalidate current command line number */
2456 if (PL_lex_brackets <= 0)
2457 yyerror("Unmatched right bracket");
2459 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2460 if (PL_lex_brackets < PL_lex_formbrack)
2461 PL_lex_formbrack = 0;
2462 if (PL_lex_state == LEX_INTERPNORMAL) {
2463 if (PL_lex_brackets == 0) {
2464 if (PL_lex_fakebrack) {
2465 PL_lex_state = LEX_INTERPEND;
2467 return yylex(); /* ignore fake brackets */
2469 if (*s == '-' && s[1] == '>')
2470 PL_lex_state = LEX_INTERPENDMAYBE;
2471 else if (*s != '[' && *s != '{')
2472 PL_lex_state = LEX_INTERPEND;
2475 if (PL_lex_brackets < PL_lex_fakebrack) {
2477 PL_lex_fakebrack = 0;
2478 return yylex(); /* ignore fake brackets */
2488 if (PL_expect == XOPERATOR) {
2489 if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && PL_bufptr == PL_linestart) {
2490 PL_curcop->cop_line--;
2491 warner(WARN_SEMICOLON, warn_nosemi);
2492 PL_curcop->cop_line++;
2497 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2499 PL_expect = XOPERATOR;
2500 force_ident(PL_tokenbuf, '&');
2504 yylval.ival = (OPpENTERSUB_AMPER<<8);
2523 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2524 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2526 if (PL_expect == XSTATE && isALPHA(tmp) &&
2527 (s == PL_linestart+1 || s[-2] == '\n') )
2529 if (PL_in_eval && !PL_rsfp) {
2534 if (strnEQ(s,"=cut",4)) {
2548 PL_doextract = TRUE;
2551 if (PL_lex_brackets < PL_lex_formbrack) {
2553 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2554 if (*t == '\n' || *t == '#') {
2572 if (PL_expect != XOPERATOR) {
2573 if (s[1] != '<' && !strchr(s,'>'))
2576 s = scan_heredoc(s);
2578 s = scan_inputsymbol(s);
2579 TERM(sublex_start());
2584 SHop(OP_LEFT_SHIFT);
2598 SHop(OP_RIGHT_SHIFT);
2607 if (PL_expect == XOPERATOR) {
2608 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2611 return ','; /* grandfather non-comma-format format */
2615 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
2616 if (PL_expect == XOPERATOR)
2617 no_op("Array length", PL_bufptr);
2618 PL_tokenbuf[0] = '@';
2619 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2621 if (!PL_tokenbuf[1])
2623 PL_expect = XOPERATOR;
2624 PL_pending_ident = '#';
2628 if (PL_expect == XOPERATOR)
2629 no_op("Scalar", PL_bufptr);
2630 PL_tokenbuf[0] = '$';
2631 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2632 if (!PL_tokenbuf[1]) {
2634 yyerror("Final $ should be \\$ or $name");
2638 /* This kludge not intended to be bulletproof. */
2639 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2640 yylval.opval = newSVOP(OP_CONST, 0,
2641 newSViv((IV)PL_compiling.cop_arybase));
2642 yylval.opval->op_private = OPpCONST_ARYBASE;
2647 if (PL_lex_state == LEX_NORMAL)
2650 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2653 PL_tokenbuf[0] = '@';
2654 if (ckWARN(WARN_SYNTAX)) {
2656 isSPACE(*t) || isALNUM(*t) || *t == '$';
2659 PL_bufptr = skipspace(PL_bufptr);
2660 while (t < PL_bufend && *t != ']')
2663 "Multidimensional syntax %.*s not supported",
2664 (t - PL_bufptr) + 1, PL_bufptr);
2668 else if (*s == '{') {
2669 PL_tokenbuf[0] = '%';
2670 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2671 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2673 char tmpbuf[sizeof PL_tokenbuf];
2675 for (t++; isSPACE(*t); t++) ;
2676 if (isIDFIRST(*t)) {
2677 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2678 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2680 "You need to quote \"%s\"", tmpbuf);
2686 PL_expect = XOPERATOR;
2687 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2688 bool islop = (PL_last_lop == PL_oldoldbufptr);
2689 if (!islop || PL_last_lop_op == OP_GREPSTART)
2690 PL_expect = XOPERATOR;
2691 else if (strchr("$@\"'`q", *s))
2692 PL_expect = XTERM; /* e.g. print $fh "foo" */
2693 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2694 PL_expect = XTERM; /* e.g. print $fh &sub */
2695 else if (isIDFIRST(*s)) {
2696 char tmpbuf[sizeof PL_tokenbuf];
2697 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2698 if (tmp = keyword(tmpbuf, len)) {
2699 /* binary operators exclude handle interpretations */
2711 PL_expect = XTERM; /* e.g. print $fh length() */
2716 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2717 if (gv && GvCVu(gv))
2718 PL_expect = XTERM; /* e.g. print $fh subr() */
2721 else if (isDIGIT(*s))
2722 PL_expect = XTERM; /* e.g. print $fh 3 */
2723 else if (*s == '.' && isDIGIT(s[1]))
2724 PL_expect = XTERM; /* e.g. print $fh .3 */
2725 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2726 PL_expect = XTERM; /* e.g. print $fh -1 */
2727 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2728 PL_expect = XTERM; /* print $fh <<"EOF" */
2730 PL_pending_ident = '$';
2734 if (PL_expect == XOPERATOR)
2736 PL_tokenbuf[0] = '@';
2737 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2738 if (!PL_tokenbuf[1]) {
2740 yyerror("Final @ should be \\@ or @name");
2743 if (PL_lex_state == LEX_NORMAL)
2745 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2747 PL_tokenbuf[0] = '%';
2749 /* Warn about @ where they meant $. */
2750 if (ckWARN(WARN_SYNTAX)) {
2751 if (*s == '[' || *s == '{') {
2753 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2755 if (*t == '}' || *t == ']') {
2757 PL_bufptr = skipspace(PL_bufptr);
2759 "Scalar value %.*s better written as $%.*s",
2760 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2765 PL_pending_ident = '@';
2768 case '/': /* may either be division or pattern */
2769 case '?': /* may either be conditional or pattern */
2770 if (PL_expect != XOPERATOR) {
2771 /* Disable warning on "study /blah/" */
2772 if (PL_oldoldbufptr == PL_last_uni
2773 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2774 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2776 s = scan_pat(s,OP_MATCH);
2777 TERM(sublex_start());
2785 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack && s[1] == '\n' &&
2786 (s == PL_linestart || s[-1] == '\n') ) {
2787 PL_lex_formbrack = 0;
2791 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2797 yylval.ival = OPf_SPECIAL;
2803 if (PL_expect != XOPERATOR)
2808 case '0': case '1': case '2': case '3': case '4':
2809 case '5': case '6': case '7': case '8': case '9':
2811 if (PL_expect == XOPERATOR)
2817 if (PL_expect == XOPERATOR) {
2818 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2821 return ','; /* grandfather non-comma-format format */
2827 missingterm((char*)0);
2828 yylval.ival = OP_CONST;
2829 TERM(sublex_start());
2833 if (PL_expect == XOPERATOR) {
2834 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2837 return ','; /* grandfather non-comma-format format */
2843 missingterm((char*)0);
2844 yylval.ival = OP_CONST;
2845 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2846 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2847 yylval.ival = OP_STRINGIFY;
2851 TERM(sublex_start());
2855 if (PL_expect == XOPERATOR)
2856 no_op("Backticks",s);
2858 missingterm((char*)0);
2859 yylval.ival = OP_BACKTICK;
2861 TERM(sublex_start());
2865 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2866 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2868 if (PL_expect == XOPERATOR)
2869 no_op("Backslash",s);
2873 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2912 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2914 /* Some keywords can be followed by any delimiter, including ':' */
2915 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2916 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2917 (PL_tokenbuf[0] == 'q' &&
2918 strchr("qwxr", PL_tokenbuf[1]))));
2920 /* x::* is just a word, unless x is "CORE" */
2921 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2925 while (d < PL_bufend && isSPACE(*d))
2926 d++; /* no comments skipped here, or s### is misparsed */
2928 /* Is this a label? */
2929 if (!tmp && PL_expect == XSTATE
2930 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2932 yylval.pval = savepv(PL_tokenbuf);
2937 /* Check for keywords */
2938 tmp = keyword(PL_tokenbuf, len);
2940 /* Is this a word before a => operator? */
2941 if (strnEQ(d,"=>",2)) {
2943 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2944 yylval.opval->op_private = OPpCONST_BARE;
2948 if (tmp < 0) { /* second-class keyword? */
2949 GV *ogv = Nullgv; /* override (winner) */
2950 GV *hgv = Nullgv; /* hidden (loser) */
2951 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2953 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
2956 if (GvIMPORTED_CV(gv))
2958 else if (! CvMETHOD(cv))
2962 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2963 (gv = *gvp) != (GV*)&PL_sv_undef &&
2964 GvCVu(gv) && GvIMPORTED_CV(gv))
2970 tmp = 0; /* overridden by import or by GLOBAL */
2973 && -tmp==KEY_lock /* XXX generalizable kludge */
2974 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
2976 tmp = 0; /* any sub overrides "weak" keyword */
2978 else { /* no override */
2982 if (ckWARN(WARN_AMBIGUOUS) && hgv
2983 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
2984 warner(WARN_AMBIGUOUS,
2985 "Ambiguous call resolved as CORE::%s(), %s",
2986 GvENAME(hgv), "qualify as such or use &");
2993 default: /* not a keyword */
2996 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
2998 /* Get the rest if it looks like a package qualifier */
3000 if (*s == '\'' || *s == ':' && s[1] == ':') {
3002 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3005 croak("Bad name after %s%s", PL_tokenbuf,
3006 *s == '\'' ? "'" : "::");
3010 if (PL_expect == XOPERATOR) {
3011 if (PL_bufptr == PL_linestart) {
3012 PL_curcop->cop_line--;
3013 warner(WARN_SEMICOLON, warn_nosemi);
3014 PL_curcop->cop_line++;
3017 no_op("Bareword",s);
3020 /* Look for a subroutine with this name in current package,
3021 unless name is "Foo::", in which case Foo is a bearword
3022 (and a package name). */
3025 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3027 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3029 "Bareword \"%s\" refers to nonexistent package",
3032 PL_tokenbuf[len] = '\0';
3039 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3042 /* if we saw a global override before, get the right name */
3045 sv = newSVpv("CORE::GLOBAL::",14);
3046 sv_catpv(sv,PL_tokenbuf);
3049 sv = newSVpv(PL_tokenbuf,0);
3051 /* Presume this is going to be a bareword of some sort. */
3054 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3055 yylval.opval->op_private = OPpCONST_BARE;
3057 /* And if "Foo::", then that's what it certainly is. */
3062 /* See if it's the indirect object for a list operator. */
3064 if (PL_oldoldbufptr &&
3065 PL_oldoldbufptr < PL_bufptr &&
3066 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3067 /* NO SKIPSPACE BEFORE HERE! */
3069 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3070 || (PL_last_lop_op == OP_ENTERSUB
3072 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3074 bool immediate_paren = *s == '(';
3076 /* (Now we can afford to cross potential line boundary.) */
3079 /* Two barewords in a row may indicate method call. */
3081 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
3084 /* If not a declared subroutine, it's an indirect object. */
3085 /* (But it's an indir obj regardless for sort.) */
3087 if ((PL_last_lop_op == OP_SORT ||
3088 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3089 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3090 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3095 /* If followed by a paren, it's certainly a subroutine. */
3097 PL_expect = XOPERATOR;
3101 if (gv && GvCVu(gv)) {
3102 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3103 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3108 PL_nextval[PL_nexttoke].opval = yylval.opval;
3109 PL_expect = XOPERATOR;
3115 /* If followed by var or block, call it a method (unless sub) */
3117 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3118 PL_last_lop = PL_oldbufptr;
3119 PL_last_lop_op = OP_METHOD;
3123 /* If followed by a bareword, see if it looks like indir obj. */
3125 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3128 /* Not a method, so call it a subroutine (if defined) */
3130 if (gv && GvCVu(gv)) {
3132 if (lastchar == '-')
3133 warn("Ambiguous use of -%s resolved as -&%s()",
3134 PL_tokenbuf, PL_tokenbuf);
3135 PL_last_lop = PL_oldbufptr;
3136 PL_last_lop_op = OP_ENTERSUB;
3137 /* Check for a constant sub */
3139 if ((sv = cv_const_sv(cv))) {
3141 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3142 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3143 yylval.opval->op_private = 0;
3147 /* Resolve to GV now. */
3148 op_free(yylval.opval);
3149 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3150 /* Is there a prototype? */
3153 PL_last_proto = SvPV((SV*)cv, len);
3156 if (strEQ(PL_last_proto, "$"))
3158 if (*PL_last_proto == '&' && *s == '{') {
3159 sv_setpv(PL_subname,"__ANON__");
3163 PL_last_proto = NULL;
3164 PL_nextval[PL_nexttoke].opval = yylval.opval;
3170 if (PL_hints & HINT_STRICT_SUBS &&
3173 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3174 PL_last_lop_op != OP_ACCEPT &&
3175 PL_last_lop_op != OP_PIPE_OP &&
3176 PL_last_lop_op != OP_SOCKPAIR)
3179 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3184 /* Call it a bare word */
3187 if (ckWARN(WARN_RESERVED)) {
3188 if (lastchar != '-') {
3189 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3191 warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
3196 if (lastchar && strchr("*%&", lastchar)) {
3197 warn("Operator or semicolon missing before %c%s",
3198 lastchar, PL_tokenbuf);
3199 warn("Ambiguous use of %c resolved as operator %c",
3200 lastchar, lastchar);
3206 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3207 newSVsv(GvSV(PL_curcop->cop_filegv)));
3211 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3212 newSVpvf("%ld", (long)PL_curcop->cop_line));
3215 case KEY___PACKAGE__:
3216 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3218 ? newSVsv(PL_curstname)
3227 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3228 char *pname = "main";
3229 if (PL_tokenbuf[2] == 'D')
3230 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3231 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3234 GvIOp(gv) = newIO();
3235 IoIFP(GvIOp(gv)) = PL_rsfp;
3236 #if defined(HAS_FCNTL) && defined(F_SETFD)
3238 int fd = PerlIO_fileno(PL_rsfp);
3239 fcntl(fd,F_SETFD,fd >= 3);
3242 /* Mark this internal pseudo-handle as clean */
3243 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3245 IoTYPE(GvIOp(gv)) = '|';
3246 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3247 IoTYPE(GvIOp(gv)) = '-';
3249 IoTYPE(GvIOp(gv)) = '<';
3260 if (PL_expect == XSTATE) {
3267 if (*s == ':' && s[1] == ':') {
3270 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3271 tmp = keyword(PL_tokenbuf, len);
3285 LOP(OP_ACCEPT,XTERM);
3291 LOP(OP_ATAN2,XTERM);
3300 LOP(OP_BLESS,XTERM);
3309 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3326 if (!PL_cryptseen++)
3329 LOP(OP_CRYPT,XTERM);
3332 if (ckWARN(WARN_OCTAL)) {
3333 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3334 if (*d != '0' && isDIGIT(*d))
3335 yywarn("chmod: mode argument is missing initial 0");
3337 LOP(OP_CHMOD,XTERM);
3340 LOP(OP_CHOWN,XTERM);
3343 LOP(OP_CONNECT,XTERM);
3359 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3363 PL_hints |= HINT_BLOCK_SCOPE;
3373 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3374 LOP(OP_DBMOPEN,XTERM);
3380 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3387 yylval.ival = PL_curcop->cop_line;
3401 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3402 UNIBRACK(OP_ENTEREVAL);
3417 case KEY_endhostent:
3423 case KEY_endservent:
3426 case KEY_endprotoent:
3437 yylval.ival = PL_curcop->cop_line;
3439 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3441 if ((PL_bufend - p) >= 3 &&
3442 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3446 croak("Missing $ on loop variable");
3451 LOP(OP_FORMLINE,XTERM);
3457 LOP(OP_FCNTL,XTERM);
3463 LOP(OP_FLOCK,XTERM);
3472 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3475 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3490 case KEY_getpriority:
3491 LOP(OP_GETPRIORITY,XTERM);
3493 case KEY_getprotobyname:
3496 case KEY_getprotobynumber:
3497 LOP(OP_GPBYNUMBER,XTERM);
3499 case KEY_getprotoent:
3511 case KEY_getpeername:
3512 UNI(OP_GETPEERNAME);
3514 case KEY_gethostbyname:
3517 case KEY_gethostbyaddr:
3518 LOP(OP_GHBYADDR,XTERM);
3520 case KEY_gethostent:
3523 case KEY_getnetbyname:
3526 case KEY_getnetbyaddr:
3527 LOP(OP_GNBYADDR,XTERM);
3532 case KEY_getservbyname:
3533 LOP(OP_GSBYNAME,XTERM);
3535 case KEY_getservbyport:
3536 LOP(OP_GSBYPORT,XTERM);
3538 case KEY_getservent:
3541 case KEY_getsockname:
3542 UNI(OP_GETSOCKNAME);
3544 case KEY_getsockopt:
3545 LOP(OP_GSOCKOPT,XTERM);
3567 yylval.ival = PL_curcop->cop_line;
3571 LOP(OP_INDEX,XTERM);
3577 LOP(OP_IOCTL,XTERM);
3589 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3620 LOP(OP_LISTEN,XTERM);
3629 s = scan_pat(s,OP_MATCH);
3630 TERM(sublex_start());
3633 LOP(OP_MAPSTART,XREF);
3636 LOP(OP_MKDIR,XTERM);
3639 LOP(OP_MSGCTL,XTERM);
3642 LOP(OP_MSGGET,XTERM);
3645 LOP(OP_MSGRCV,XTERM);
3648 LOP(OP_MSGSND,XTERM);
3653 if (isIDFIRST(*s)) {
3654 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3655 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3656 if (!PL_in_my_stash) {
3659 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3666 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3673 if (PL_expect != XSTATE)
3674 yyerror("\"no\" not allowed in expression");
3675 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3676 s = force_version(s);
3685 if (isIDFIRST(*s)) {
3687 for (d = s; isALNUM(*d); d++) ;
3689 if (strchr("|&*+-=!?:.", *t))
3690 warn("Precedence problem: open %.*s should be open(%.*s)",
3696 yylval.ival = OP_OR;
3706 LOP(OP_OPEN_DIR,XTERM);
3709 checkcomma(s,PL_tokenbuf,"filehandle");
3713 checkcomma(s,PL_tokenbuf,"filehandle");
3732 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3736 LOP(OP_PIPE_OP,XTERM);
3741 missingterm((char*)0);
3742 yylval.ival = OP_CONST;
3743 TERM(sublex_start());
3751 missingterm((char*)0);
3752 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3753 d = SvPV_force(PL_lex_stuff, len);
3754 for (; len; --len, ++d) {
3757 "Possible attempt to separate words with commas");
3762 "Possible attempt to put comments in qw() list");
3768 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3769 PL_lex_stuff = Nullsv;
3772 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3775 yylval.ival = OP_SPLIT;
3779 PL_last_lop = PL_oldbufptr;
3780 PL_last_lop_op = OP_SPLIT;
3786 missingterm((char*)0);
3787 yylval.ival = OP_STRINGIFY;
3788 if (SvIVX(PL_lex_stuff) == '\'')
3789 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3790 TERM(sublex_start());
3793 s = scan_pat(s,OP_QR);
3794 TERM(sublex_start());
3799 missingterm((char*)0);
3800 yylval.ival = OP_BACKTICK;
3802 TERM(sublex_start());
3808 *PL_tokenbuf = '\0';
3809 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3810 if (isIDFIRST(*PL_tokenbuf))
3811 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3813 yyerror("<> should be quotes");
3820 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3824 LOP(OP_RENAME,XTERM);
3833 LOP(OP_RINDEX,XTERM);
3856 LOP(OP_REVERSE,XTERM);
3867 TERM(sublex_start());
3869 TOKEN(1); /* force error */
3878 LOP(OP_SELECT,XTERM);
3884 LOP(OP_SEMCTL,XTERM);
3887 LOP(OP_SEMGET,XTERM);
3890 LOP(OP_SEMOP,XTERM);
3896 LOP(OP_SETPGRP,XTERM);
3898 case KEY_setpriority:
3899 LOP(OP_SETPRIORITY,XTERM);
3901 case KEY_sethostent:
3907 case KEY_setservent:
3910 case KEY_setprotoent:
3920 LOP(OP_SEEKDIR,XTERM);
3922 case KEY_setsockopt:
3923 LOP(OP_SSOCKOPT,XTERM);
3929 LOP(OP_SHMCTL,XTERM);
3932 LOP(OP_SHMGET,XTERM);
3935 LOP(OP_SHMREAD,XTERM);
3938 LOP(OP_SHMWRITE,XTERM);
3941 LOP(OP_SHUTDOWN,XTERM);
3950 LOP(OP_SOCKET,XTERM);
3952 case KEY_socketpair:
3953 LOP(OP_SOCKPAIR,XTERM);
3956 checkcomma(s,PL_tokenbuf,"subroutine name");
3958 if (*s == ';' || *s == ')') /* probably a close */
3959 croak("sort is now a reserved word");
3961 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3965 LOP(OP_SPLIT,XTERM);
3968 LOP(OP_SPRINTF,XTERM);
3971 LOP(OP_SPLICE,XTERM);
3987 LOP(OP_SUBSTR,XTERM);
3994 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3995 char tmpbuf[sizeof PL_tokenbuf];
3997 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3998 if (strchr(tmpbuf, ':'))
3999 sv_setpv(PL_subname, tmpbuf);
4001 sv_setsv(PL_subname,PL_curstname);
4002 sv_catpvn(PL_subname,"::",2);
4003 sv_catpvn(PL_subname,tmpbuf,len);
4005 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4009 PL_expect = XTERMBLOCK;
4010 sv_setpv(PL_subname,"?");
4013 if (tmp == KEY_format) {
4016 PL_lex_formbrack = PL_lex_brackets + 1;
4020 /* Look for a prototype */
4027 SvREFCNT_dec(PL_lex_stuff);
4028 PL_lex_stuff = Nullsv;
4029 croak("Prototype not terminated");
4032 d = SvPVX(PL_lex_stuff);
4034 for (p = d; *p; ++p) {
4039 SvCUR(PL_lex_stuff) = tmp;
4042 PL_nextval[1] = PL_nextval[0];
4043 PL_nexttype[1] = PL_nexttype[0];
4044 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4045 PL_nexttype[0] = THING;
4046 if (PL_nexttoke == 1) {
4047 PL_lex_defer = PL_lex_state;
4048 PL_lex_expect = PL_expect;
4049 PL_lex_state = LEX_KNOWNEXT;
4051 PL_lex_stuff = Nullsv;
4054 if (*SvPV(PL_subname,PL_na) == '?') {
4055 sv_setpv(PL_subname,"__ANON__");
4062 LOP(OP_SYSTEM,XREF);
4065 LOP(OP_SYMLINK,XTERM);
4068 LOP(OP_SYSCALL,XTERM);
4071 LOP(OP_SYSOPEN,XTERM);
4074 LOP(OP_SYSSEEK,XTERM);
4077 LOP(OP_SYSREAD,XTERM);
4080 LOP(OP_SYSWRITE,XTERM);
4084 TERM(sublex_start());
4105 LOP(OP_TRUNCATE,XTERM);
4117 yylval.ival = PL_curcop->cop_line;
4121 yylval.ival = PL_curcop->cop_line;
4125 LOP(OP_UNLINK,XTERM);
4131 LOP(OP_UNPACK,XTERM);
4134 LOP(OP_UTIME,XTERM);
4137 if (ckWARN(WARN_OCTAL)) {
4138 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4139 if (*d != '0' && isDIGIT(*d))
4140 yywarn("umask: argument is missing initial 0");
4145 LOP(OP_UNSHIFT,XTERM);
4148 if (PL_expect != XSTATE)
4149 yyerror("\"use\" not allowed in expression");
4152 s = force_version(s);
4153 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4154 PL_nextval[PL_nexttoke].opval = Nullop;
4159 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4160 s = force_version(s);
4173 yylval.ival = PL_curcop->cop_line;
4177 PL_hints |= HINT_BLOCK_SCOPE;
4184 LOP(OP_WAITPID,XTERM);
4192 static char ctl_l[2];
4194 if (ctl_l[0] == '\0')
4195 ctl_l[0] = toCTRL('L');
4196 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4199 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4204 if (PL_expect == XOPERATOR)
4210 yylval.ival = OP_XOR;
4215 TERM(sublex_start());
4221 keyword(register char *d, I32 len)
4226 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4227 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4228 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4229 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4230 if (strEQ(d,"__END__")) return KEY___END__;
4234 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4239 if (strEQ(d,"and")) return -KEY_and;
4240 if (strEQ(d,"abs")) return -KEY_abs;
4243 if (strEQ(d,"alarm")) return -KEY_alarm;
4244 if (strEQ(d,"atan2")) return -KEY_atan2;
4247 if (strEQ(d,"accept")) return -KEY_accept;
4252 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4255 if (strEQ(d,"bless")) return -KEY_bless;
4256 if (strEQ(d,"bind")) return -KEY_bind;
4257 if (strEQ(d,"binmode")) return -KEY_binmode;
4260 if (strEQ(d,"CORE")) return -KEY_CORE;
4265 if (strEQ(d,"cmp")) return -KEY_cmp;
4266 if (strEQ(d,"chr")) return -KEY_chr;
4267 if (strEQ(d,"cos")) return -KEY_cos;
4270 if (strEQ(d,"chop")) return KEY_chop;
4273 if (strEQ(d,"close")) return -KEY_close;
4274 if (strEQ(d,"chdir")) return -KEY_chdir;
4275 if (strEQ(d,"chomp")) return KEY_chomp;
4276 if (strEQ(d,"chmod")) return -KEY_chmod;
4277 if (strEQ(d,"chown")) return -KEY_chown;
4278 if (strEQ(d,"crypt")) return -KEY_crypt;
4281 if (strEQ(d,"chroot")) return -KEY_chroot;
4282 if (strEQ(d,"caller")) return -KEY_caller;
4285 if (strEQ(d,"connect")) return -KEY_connect;
4288 if (strEQ(d,"closedir")) return -KEY_closedir;
4289 if (strEQ(d,"continue")) return -KEY_continue;
4294 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4299 if (strEQ(d,"do")) return KEY_do;
4302 if (strEQ(d,"die")) return -KEY_die;
4305 if (strEQ(d,"dump")) return -KEY_dump;
4308 if (strEQ(d,"delete")) return KEY_delete;
4311 if (strEQ(d,"defined")) return KEY_defined;
4312 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4315 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4320 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4321 if (strEQ(d,"END")) return KEY_END;
4326 if (strEQ(d,"eq")) return -KEY_eq;
4329 if (strEQ(d,"eof")) return -KEY_eof;
4330 if (strEQ(d,"exp")) return -KEY_exp;
4333 if (strEQ(d,"else")) return KEY_else;
4334 if (strEQ(d,"exit")) return -KEY_exit;
4335 if (strEQ(d,"eval")) return KEY_eval;
4336 if (strEQ(d,"exec")) return -KEY_exec;
4337 if (strEQ(d,"each")) return KEY_each;
4340 if (strEQ(d,"elsif")) return KEY_elsif;
4343 if (strEQ(d,"exists")) return KEY_exists;
4344 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4347 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4348 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4351 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4354 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4355 if (strEQ(d,"endservent")) return -KEY_endservent;
4358 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4365 if (strEQ(d,"for")) return KEY_for;
4368 if (strEQ(d,"fork")) return -KEY_fork;
4371 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4372 if (strEQ(d,"flock")) return -KEY_flock;
4375 if (strEQ(d,"format")) return KEY_format;
4376 if (strEQ(d,"fileno")) return -KEY_fileno;
4379 if (strEQ(d,"foreach")) return KEY_foreach;
4382 if (strEQ(d,"formline")) return -KEY_formline;
4388 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4389 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4393 if (strnEQ(d,"get",3)) {
4398 if (strEQ(d,"ppid")) return -KEY_getppid;
4399 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4402 if (strEQ(d,"pwent")) return -KEY_getpwent;
4403 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4404 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4407 if (strEQ(d,"peername")) return -KEY_getpeername;
4408 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4409 if (strEQ(d,"priority")) return -KEY_getpriority;
4412 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4415 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4419 else if (*d == 'h') {
4420 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4421 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4422 if (strEQ(d,"hostent")) return -KEY_gethostent;
4424 else if (*d == 'n') {
4425 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4426 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4427 if (strEQ(d,"netent")) return -KEY_getnetent;
4429 else if (*d == 's') {
4430 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4431 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4432 if (strEQ(d,"servent")) return -KEY_getservent;
4433 if (strEQ(d,"sockname")) return -KEY_getsockname;
4434 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4436 else if (*d == 'g') {
4437 if (strEQ(d,"grent")) return -KEY_getgrent;
4438 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4439 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4441 else if (*d == 'l') {
4442 if (strEQ(d,"login")) return -KEY_getlogin;
4444 else if (strEQ(d,"c")) return -KEY_getc;
4449 if (strEQ(d,"gt")) return -KEY_gt;
4450 if (strEQ(d,"ge")) return -KEY_ge;
4453 if (strEQ(d,"grep")) return KEY_grep;
4454 if (strEQ(d,"goto")) return KEY_goto;
4455 if (strEQ(d,"glob")) return KEY_glob;
4458 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4463 if (strEQ(d,"hex")) return -KEY_hex;
4466 if (strEQ(d,"INIT")) return KEY_INIT;
4471 if (strEQ(d,"if")) return KEY_if;
4474 if (strEQ(d,"int")) return -KEY_int;
4477 if (strEQ(d,"index")) return -KEY_index;
4478 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4483 if (strEQ(d,"join")) return -KEY_join;
4487 if (strEQ(d,"keys")) return KEY_keys;
4488 if (strEQ(d,"kill")) return -KEY_kill;
4493 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4494 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4500 if (strEQ(d,"lt")) return -KEY_lt;
4501 if (strEQ(d,"le")) return -KEY_le;
4502 if (strEQ(d,"lc")) return -KEY_lc;
4505 if (strEQ(d,"log")) return -KEY_log;
4508 if (strEQ(d,"last")) return KEY_last;
4509 if (strEQ(d,"link")) return -KEY_link;
4510 if (strEQ(d,"lock")) return -KEY_lock;
4513 if (strEQ(d,"local")) return KEY_local;
4514 if (strEQ(d,"lstat")) return -KEY_lstat;
4517 if (strEQ(d,"length")) return -KEY_length;
4518 if (strEQ(d,"listen")) return -KEY_listen;
4521 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4524 if (strEQ(d,"localtime")) return -KEY_localtime;
4530 case 1: return KEY_m;
4532 if (strEQ(d,"my")) return KEY_my;
4535 if (strEQ(d,"map")) return KEY_map;
4538 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4541 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4542 if (strEQ(d,"msgget")) return -KEY_msgget;
4543 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4544 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4549 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4552 if (strEQ(d,"next")) return KEY_next;
4553 if (strEQ(d,"ne")) return -KEY_ne;
4554 if (strEQ(d,"not")) return -KEY_not;
4555 if (strEQ(d,"no")) return KEY_no;
4560 if (strEQ(d,"or")) return -KEY_or;
4563 if (strEQ(d,"ord")) return -KEY_ord;
4564 if (strEQ(d,"oct")) return -KEY_oct;
4565 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4569 if (strEQ(d,"open")) return -KEY_open;
4572 if (strEQ(d,"opendir")) return -KEY_opendir;
4579 if (strEQ(d,"pop")) return KEY_pop;
4580 if (strEQ(d,"pos")) return KEY_pos;
4583 if (strEQ(d,"push")) return KEY_push;
4584 if (strEQ(d,"pack")) return -KEY_pack;
4585 if (strEQ(d,"pipe")) return -KEY_pipe;
4588 if (strEQ(d,"print")) return KEY_print;
4591 if (strEQ(d,"printf")) return KEY_printf;
4594 if (strEQ(d,"package")) return KEY_package;
4597 if (strEQ(d,"prototype")) return KEY_prototype;
4602 if (strEQ(d,"q")) return KEY_q;
4603 if (strEQ(d,"qr")) return KEY_qr;
4604 if (strEQ(d,"qq")) return KEY_qq;
4605 if (strEQ(d,"qw")) return KEY_qw;
4606 if (strEQ(d,"qx")) return KEY_qx;
4608 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4613 if (strEQ(d,"ref")) return -KEY_ref;
4616 if (strEQ(d,"read")) return -KEY_read;
4617 if (strEQ(d,"rand")) return -KEY_rand;
4618 if (strEQ(d,"recv")) return -KEY_recv;
4619 if (strEQ(d,"redo")) return KEY_redo;
4622 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4623 if (strEQ(d,"reset")) return -KEY_reset;
4626 if (strEQ(d,"return")) return KEY_return;
4627 if (strEQ(d,"rename")) return -KEY_rename;
4628 if (strEQ(d,"rindex")) return -KEY_rindex;
4631 if (strEQ(d,"require")) return -KEY_require;
4632 if (strEQ(d,"reverse")) return -KEY_reverse;
4633 if (strEQ(d,"readdir")) return -KEY_readdir;
4636 if (strEQ(d,"readlink")) return -KEY_readlink;
4637 if (strEQ(d,"readline")) return -KEY_readline;
4638 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4641 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4647 case 0: return KEY_s;
4649 if (strEQ(d,"scalar")) return KEY_scalar;
4654 if (strEQ(d,"seek")) return -KEY_seek;
4655 if (strEQ(d,"send")) return -KEY_send;
4658 if (strEQ(d,"semop")) return -KEY_semop;
4661 if (strEQ(d,"select")) return -KEY_select;
4662 if (strEQ(d,"semctl")) return -KEY_semctl;
4663 if (strEQ(d,"semget")) return -KEY_semget;
4666 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4667 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4670 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4671 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4674 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4677 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4678 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4679 if (strEQ(d,"setservent")) return -KEY_setservent;
4682 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4683 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4690 if (strEQ(d,"shift")) return KEY_shift;
4693 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4694 if (strEQ(d,"shmget")) return -KEY_shmget;
4697 if (strEQ(d,"shmread")) return -KEY_shmread;
4700 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4701 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4706 if (strEQ(d,"sin")) return -KEY_sin;
4709 if (strEQ(d,"sleep")) return -KEY_sleep;
4712 if (strEQ(d,"sort")) return KEY_sort;
4713 if (strEQ(d,"socket")) return -KEY_socket;
4714 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4717 if (strEQ(d,"split")) return KEY_split;
4718 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4719 if (strEQ(d,"splice")) return KEY_splice;
4722 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4725 if (strEQ(d,"srand")) return -KEY_srand;
4728 if (strEQ(d,"stat")) return -KEY_stat;
4729 if (strEQ(d,"study")) return KEY_study;
4732 if (strEQ(d,"substr")) return -KEY_substr;
4733 if (strEQ(d,"sub")) return KEY_sub;
4738 if (strEQ(d,"system")) return -KEY_system;
4741 if (strEQ(d,"symlink")) return -KEY_symlink;
4742 if (strEQ(d,"syscall")) return -KEY_syscall;
4743 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4744 if (strEQ(d,"sysread")) return -KEY_sysread;
4745 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4748 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4757 if (strEQ(d,"tr")) return KEY_tr;
4760 if (strEQ(d,"tie")) return KEY_tie;
4763 if (strEQ(d,"tell")) return -KEY_tell;
4764 if (strEQ(d,"tied")) return KEY_tied;
4765 if (strEQ(d,"time")) return -KEY_time;
4768 if (strEQ(d,"times")) return -KEY_times;
4771 if (strEQ(d,"telldir")) return -KEY_telldir;
4774 if (strEQ(d,"truncate")) return -KEY_truncate;
4781 if (strEQ(d,"uc")) return -KEY_uc;
4784 if (strEQ(d,"use")) return KEY_use;
4787 if (strEQ(d,"undef")) return KEY_undef;
4788 if (strEQ(d,"until")) return KEY_until;
4789 if (strEQ(d,"untie")) return KEY_untie;
4790 if (strEQ(d,"utime")) return -KEY_utime;
4791 if (strEQ(d,"umask")) return -KEY_umask;
4794 if (strEQ(d,"unless")) return KEY_unless;
4795 if (strEQ(d,"unpack")) return -KEY_unpack;
4796 if (strEQ(d,"unlink")) return -KEY_unlink;
4799 if (strEQ(d,"unshift")) return KEY_unshift;
4800 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4805 if (strEQ(d,"values")) return -KEY_values;
4806 if (strEQ(d,"vec")) return -KEY_vec;
4811 if (strEQ(d,"warn")) return -KEY_warn;
4812 if (strEQ(d,"wait")) return -KEY_wait;
4815 if (strEQ(d,"while")) return KEY_while;
4816 if (strEQ(d,"write")) return -KEY_write;
4819 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4822 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4827 if (len == 1) return -KEY_x;
4828 if (strEQ(d,"xor")) return -KEY_xor;
4831 if (len == 1) return KEY_y;
4840 checkcomma(register char *s, char *name, char *what)
4844 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4845 dTHR; /* only for ckWARN */
4846 if (ckWARN(WARN_SYNTAX)) {
4848 for (w = s+2; *w && level; w++) {
4855 for (; *w && isSPACE(*w); w++) ;
4856 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4857 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4860 while (s < PL_bufend && isSPACE(*s))
4864 while (s < PL_bufend && isSPACE(*s))
4866 if (isIDFIRST(*s)) {
4870 while (s < PL_bufend && isSPACE(*s))
4875 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4879 croak("No comma allowed after %s", what);
4885 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4888 HV *table = GvHV(PL_hintgv); /* ^H */
4891 bool oldcatch = CATCH_GET;
4897 yyerror("%^H is not defined");
4900 cvp = hv_fetch(table, key, strlen(key), FALSE);
4901 if (!cvp || !SvOK(*cvp)) {
4902 sprintf(buf,"$^H{%s} is not defined", key);
4906 sv_2mortal(sv); /* Parent created it permanently */
4909 pv = sv_2mortal(newSVpv(s, len));
4911 typesv = sv_2mortal(newSVpv(type, 0));
4913 typesv = &PL_sv_undef;
4915 Zero(&myop, 1, BINOP);
4916 myop.op_last = (OP *) &myop;
4917 myop.op_next = Nullop;
4918 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4920 PUSHSTACKi(PERLSI_OVERLOAD);
4923 PL_op = (OP *) &myop;
4924 if (PERLDB_SUB && PL_curstash != PL_debstash)
4925 PL_op->op_private |= OPpENTERSUB_DB;
4936 if (PL_op = pp_entersub(ARGS))
4943 CATCH_SET(oldcatch);
4947 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4950 return SvREFCNT_inc(res);
4954 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4956 register char *d = dest;
4957 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4960 croak(ident_too_long);
4963 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4968 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4972 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
4973 char *t = s + UTF8SKIP(s);
4974 while (*t & 0x80 && is_utf8_mark((U8*)t))
4976 if (d + (t - s) > e)
4977 croak(ident_too_long);
4978 Copy(s, d, t - s, char);
4991 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4998 if (PL_lex_brackets == 0)
4999 PL_lex_fakebrack = 0;
5003 e = d + destlen - 3; /* two-character token, ending NUL */
5005 while (isDIGIT(*s)) {
5007 croak(ident_too_long);
5014 croak(ident_too_long);
5017 else if (*s == '\'' && isIDFIRST(s[1])) {
5022 else if (*s == ':' && s[1] == ':') {
5026 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
5027 char *t = s + UTF8SKIP(s);
5028 while (*t & 0x80 && is_utf8_mark((U8*)t))
5030 if (d + (t - s) > e)
5031 croak(ident_too_long);
5032 Copy(s, d, t - s, char);
5043 if (PL_lex_state != LEX_NORMAL)
5044 PL_lex_state = LEX_INTERPENDMAYBE;
5047 if (*s == '$' && s[1] &&
5048 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5050 if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
5051 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
5064 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5069 if (isSPACE(s[-1])) {
5072 if (ch != ' ' && ch != '\t') {
5078 if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8((U8*)d))) {
5082 while (e < send && (isALNUM(*e) || ((*e & 0xc0) == 0x80 && isALNUM_utf8((U8*)e)) || *e == ':')) {
5084 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5087 Copy(s, d, e - s, char);
5092 while (isALNUM(*s) || *s == ':')
5096 while (s < send && (*s == ' ' || *s == '\t')) s++;
5097 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5098 dTHR; /* only for ckWARN */
5099 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5100 char *brack = *s == '[' ? "[...]" : "{...}";
5101 warner(WARN_AMBIGUOUS,
5102 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5103 funny, dest, brack, funny, dest, brack);
5105 PL_lex_fakebrack = PL_lex_brackets+1;
5107 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5113 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5114 PL_lex_state = LEX_INTERPEND;
5117 if (PL_lex_state == LEX_NORMAL) {
5118 dTHR; /* only for ckWARN */
5119 if (ckWARN(WARN_AMBIGUOUS) &&
5120 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5122 warner(WARN_AMBIGUOUS,
5123 "Ambiguous use of %c{%s} resolved to %c%s",
5124 funny, dest, funny, dest);
5129 s = bracket; /* let the parser handle it */
5133 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5134 PL_lex_state = LEX_INTERPEND;
5138 void pmflag(U16 *pmfl, int ch)
5143 *pmfl |= PMf_GLOBAL;
5145 *pmfl |= PMf_CONTINUE;
5149 *pmfl |= PMf_MULTILINE;
5151 *pmfl |= PMf_SINGLELINE;
5153 *pmfl |= PMf_EXTENDED;
5157 scan_pat(char *start, I32 type)
5162 s = scan_str(start);
5165 SvREFCNT_dec(PL_lex_stuff);
5166 PL_lex_stuff = Nullsv;
5167 croak("Search pattern not terminated");
5170 pm = (PMOP*)newPMOP(type, 0);
5171 if (PL_multi_open == '?')
5172 pm->op_pmflags |= PMf_ONCE;
5174 while (*s && strchr("iomsx", *s))
5175 pmflag(&pm->op_pmflags,*s++);
5178 while (*s && strchr("iogcmsx", *s))
5179 pmflag(&pm->op_pmflags,*s++);
5181 pm->op_pmpermflags = pm->op_pmflags;
5183 PL_lex_op = (OP*)pm;
5184 yylval.ival = OP_MATCH;
5189 scan_subst(char *start)
5196 yylval.ival = OP_NULL;
5198 s = scan_str(start);
5202 SvREFCNT_dec(PL_lex_stuff);
5203 PL_lex_stuff = Nullsv;
5204 croak("Substitution pattern not terminated");
5207 if (s[-1] == PL_multi_open)
5210 first_start = PL_multi_start;
5214 SvREFCNT_dec(PL_lex_stuff);
5215 PL_lex_stuff = Nullsv;
5217 SvREFCNT_dec(PL_lex_repl);
5218 PL_lex_repl = Nullsv;
5219 croak("Substitution replacement not terminated");
5221 PL_multi_start = first_start; /* so whole substitution is taken together */
5223 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5229 else if (strchr("iogcmsx", *s))
5230 pmflag(&pm->op_pmflags,*s++);
5237 pm->op_pmflags |= PMf_EVAL;
5238 repl = newSVpv("",0);
5240 sv_catpv(repl, es ? "eval " : "do ");
5241 sv_catpvn(repl, "{ ", 2);
5242 sv_catsv(repl, PL_lex_repl);
5243 sv_catpvn(repl, " };", 2);
5244 SvCOMPILED_on(repl);
5245 SvREFCNT_dec(PL_lex_repl);
5249 pm->op_pmpermflags = pm->op_pmflags;
5250 PL_lex_op = (OP*)pm;
5251 yylval.ival = OP_SUBST;
5256 scan_trans(char *start)
5267 yylval.ival = OP_NULL;
5269 s = scan_str(start);
5272 SvREFCNT_dec(PL_lex_stuff);
5273 PL_lex_stuff = Nullsv;
5274 croak("Transliteration pattern not terminated");
5276 if (s[-1] == PL_multi_open)
5282 SvREFCNT_dec(PL_lex_stuff);
5283 PL_lex_stuff = Nullsv;
5285 SvREFCNT_dec(PL_lex_repl);
5286 PL_lex_repl = Nullsv;
5287 croak("Transliteration replacement not terminated");
5291 o = newSVOP(OP_TRANS, 0, 0);
5292 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5295 New(803,tbl,256,short);
5296 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5300 complement = del = squash = 0;
5301 while (strchr("cdsCU", *s)) {
5303 complement = OPpTRANS_COMPLEMENT;
5305 del = OPpTRANS_DELETE;
5307 squash = OPpTRANS_SQUASH;
5312 utf8 &= ~OPpTRANS_FROM_UTF;
5314 utf8 |= OPpTRANS_FROM_UTF;
5318 utf8 &= ~OPpTRANS_TO_UTF;
5320 utf8 |= OPpTRANS_TO_UTF;
5323 croak("Too many /C and /U options");
5328 o->op_private = del|squash|complement|utf8;
5331 yylval.ival = OP_TRANS;
5336 scan_heredoc(register char *s)
5340 I32 op_type = OP_SCALAR;
5347 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5351 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5354 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5355 if (*peek && strchr("`'\"",*peek)) {
5358 s = delimcpy(d, e, s, PL_bufend, term, &len);
5369 deprecate("bare << to mean <<\"\"");
5370 for (; isALNUM(*s); s++) {
5375 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5376 croak("Delimiter for here document is too long");
5379 len = d - PL_tokenbuf;
5380 #ifndef PERL_STRICT_CR
5381 d = strchr(s, '\r');
5385 while (s < PL_bufend) {
5391 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5400 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5405 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5406 herewas = newSVpv(s,PL_bufend-s);
5408 s--, herewas = newSVpv(s,d-s);
5409 s += SvCUR(herewas);
5411 tmpstr = NEWSV(87,79);
5412 sv_upgrade(tmpstr, SVt_PVIV);
5417 else if (term == '`') {
5418 op_type = OP_BACKTICK;
5419 SvIVX(tmpstr) = '\\';
5423 PL_multi_start = PL_curcop->cop_line;
5424 PL_multi_open = PL_multi_close = '<';
5425 term = *PL_tokenbuf;
5428 while (s < PL_bufend &&
5429 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5431 PL_curcop->cop_line++;
5433 if (s >= PL_bufend) {
5434 PL_curcop->cop_line = PL_multi_start;
5435 missingterm(PL_tokenbuf);
5437 sv_setpvn(tmpstr,d+1,s-d);
5439 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5441 sv_catpvn(herewas,s,PL_bufend-s);
5442 sv_setsv(PL_linestr,herewas);
5443 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5444 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5447 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5448 while (s >= PL_bufend) { /* multiple line string? */
5450 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5451 PL_curcop->cop_line = PL_multi_start;
5452 missingterm(PL_tokenbuf);
5454 PL_curcop->cop_line++;
5455 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5456 #ifndef PERL_STRICT_CR
5457 if (PL_bufend - PL_linestart >= 2) {
5458 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5459 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5461 PL_bufend[-2] = '\n';
5463 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5465 else if (PL_bufend[-1] == '\r')
5466 PL_bufend[-1] = '\n';
5468 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5469 PL_bufend[-1] = '\n';
5471 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5472 SV *sv = NEWSV(88,0);
5474 sv_upgrade(sv, SVt_PVMG);
5475 sv_setsv(sv,PL_linestr);
5476 av_store(GvAV(PL_curcop->cop_filegv),
5477 (I32)PL_curcop->cop_line,sv);
5479 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5482 sv_catsv(PL_linestr,herewas);
5483 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5487 sv_catsv(tmpstr,PL_linestr);
5490 PL_multi_end = PL_curcop->cop_line;
5492 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5493 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5494 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5496 SvREFCNT_dec(herewas);
5497 PL_lex_stuff = tmpstr;
5498 yylval.ival = op_type;
5503 takes: current position in input buffer
5504 returns: new position in input buffer
5505 side-effects: yylval and lex_op are set.
5510 <FH> read from filehandle
5511 <pkg::FH> read from package qualified filehandle
5512 <pkg'FH> read from package qualified filehandle
5513 <$fh> read from filehandle in $fh
5519 scan_inputsymbol(char *start)
5521 register char *s = start; /* current position in buffer */
5526 d = PL_tokenbuf; /* start of temp holding space */
5527 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5528 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5530 /* die if we didn't have space for the contents of the <>,
5534 if (len >= sizeof PL_tokenbuf)
5535 croak("Excessively long <> operator");
5537 croak("Unterminated <> operator");
5542 Remember, only scalar variables are interpreted as filehandles by
5543 this code. Anything more complex (e.g., <$fh{$num}>) will be
5544 treated as a glob() call.
5545 This code makes use of the fact that except for the $ at the front,
5546 a scalar variable and a filehandle look the same.
5548 if (*d == '$' && d[1]) d++;
5550 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5551 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5554 /* If we've tried to read what we allow filehandles to look like, and
5555 there's still text left, then it must be a glob() and not a getline.
5556 Use scan_str to pull out the stuff between the <> and treat it
5557 as nothing more than a string.
5560 if (d - PL_tokenbuf != len) {
5561 yylval.ival = OP_GLOB;
5563 s = scan_str(start);
5565 croak("Glob not terminated");
5569 /* we're in a filehandle read situation */
5572 /* turn <> into <ARGV> */
5574 (void)strcpy(d,"ARGV");
5576 /* if <$fh>, create the ops to turn the variable into a
5582 /* try to find it in the pad for this block, otherwise find
5583 add symbol table ops
5585 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5586 OP *o = newOP(OP_PADSV, 0);
5588 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5591 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5592 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5593 newUNOP(OP_RV2GV, 0,
5594 newUNOP(OP_RV2SV, 0,
5595 newGVOP(OP_GV, 0, gv))));
5597 /* we created the ops in lex_op, so make yylval.ival a null op */
5598 yylval.ival = OP_NULL;
5601 /* If it's none of the above, it must be a literal filehandle
5602 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5604 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5605 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5606 yylval.ival = OP_NULL;
5615 takes: start position in buffer
5616 returns: position to continue reading from buffer
5617 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5618 updates the read buffer.
5620 This subroutine pulls a string out of the input. It is called for:
5621 q single quotes q(literal text)
5622 ' single quotes 'literal text'
5623 qq double quotes qq(interpolate $here please)
5624 " double quotes "interpolate $here please"
5625 qx backticks qx(/bin/ls -l)
5626 ` backticks `/bin/ls -l`
5627 qw quote words @EXPORT_OK = qw( func() $spam )
5628 m// regexp match m/this/
5629 s/// regexp substitute s/this/that/
5630 tr/// string transliterate tr/this/that/
5631 y/// string transliterate y/this/that/
5632 ($*@) sub prototypes sub foo ($)
5633 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5635 In most of these cases (all but <>, patterns and transliterate)
5636 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5637 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5638 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5641 It skips whitespace before the string starts, and treats the first
5642 character as the delimiter. If the delimiter is one of ([{< then
5643 the corresponding "close" character )]}> is used as the closing
5644 delimiter. It allows quoting of delimiters, and if the string has
5645 balanced delimiters ([{<>}]) it allows nesting.
5647 The lexer always reads these strings into lex_stuff, except in the
5648 case of the operators which take *two* arguments (s/// and tr///)
5649 when it checks to see if lex_stuff is full (presumably with the 1st
5650 arg to s or tr) and if so puts the string into lex_repl.
5655 scan_str(char *start)
5658 SV *sv; /* scalar value: string */
5659 char *tmps; /* temp string, used for delimiter matching */
5660 register char *s = start; /* current position in the buffer */
5661 register char term; /* terminating character */
5662 register char *to; /* current position in the sv's data */
5663 I32 brackets = 1; /* bracket nesting level */
5665 /* skip space before the delimiter */
5669 /* mark where we are, in case we need to report errors */
5672 /* after skipping whitespace, the next character is the terminator */
5674 /* mark where we are */
5675 PL_multi_start = PL_curcop->cop_line;
5676 PL_multi_open = term;
5678 /* find corresponding closing delimiter */
5679 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5681 PL_multi_close = term;
5683 /* create a new SV to hold the contents. 87 is leak category, I'm
5684 assuming. 79 is the SV's initial length. What a random number. */
5686 sv_upgrade(sv, SVt_PVIV);
5688 (void)SvPOK_only(sv); /* validate pointer */
5690 /* move past delimiter and try to read a complete string */
5693 /* extend sv if need be */
5694 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5695 /* set 'to' to the next character in the sv's string */
5696 to = SvPVX(sv)+SvCUR(sv);
5698 /* if open delimiter is the close delimiter read unbridle */
5699 if (PL_multi_open == PL_multi_close) {
5700 for (; s < PL_bufend; s++,to++) {
5701 /* embedded newlines increment the current line number */
5702 if (*s == '\n' && !PL_rsfp)
5703 PL_curcop->cop_line++;
5704 /* handle quoted delimiters */
5705 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5708 /* any other quotes are simply copied straight through */
5712 /* terminate when run out of buffer (the for() condition), or
5713 have found the terminator */
5714 else if (*s == term)
5720 /* if the terminator isn't the same as the start character (e.g.,
5721 matched brackets), we have to allow more in the quoting, and
5722 be prepared for nested brackets.
5725 /* read until we run out of string, or we find the terminator */
5726 for (; s < PL_bufend; s++,to++) {
5727 /* embedded newlines increment the line count */
5728 if (*s == '\n' && !PL_rsfp)
5729 PL_curcop->cop_line++;
5730 /* backslashes can escape the open or closing characters */
5731 if (*s == '\\' && s+1 < PL_bufend) {
5732 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5737 /* allow nested opens and closes */
5738 else if (*s == PL_multi_close && --brackets <= 0)
5740 else if (*s == PL_multi_open)
5745 /* terminate the copied string and update the sv's end-of-string */
5747 SvCUR_set(sv, to - SvPVX(sv));
5750 * this next chunk reads more into the buffer if we're not done yet
5753 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5755 #ifndef PERL_STRICT_CR
5756 if (to - SvPVX(sv) >= 2) {
5757 if ((to[-2] == '\r' && to[-1] == '\n') ||
5758 (to[-2] == '\n' && to[-1] == '\r'))
5762 SvCUR_set(sv, to - SvPVX(sv));
5764 else if (to[-1] == '\r')
5767 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5771 /* if we're out of file, or a read fails, bail and reset the current
5772 line marker so we can report where the unterminated string began
5775 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5777 PL_curcop->cop_line = PL_multi_start;
5780 /* we read a line, so increment our line counter */
5781 PL_curcop->cop_line++;
5783 /* update debugger info */
5784 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5785 SV *sv = NEWSV(88,0);
5787 sv_upgrade(sv, SVt_PVMG);
5788 sv_setsv(sv,PL_linestr);
5789 av_store(GvAV(PL_curcop->cop_filegv),
5790 (I32)PL_curcop->cop_line, sv);
5793 /* having changed the buffer, we must update PL_bufend */
5794 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5797 /* at this point, we have successfully read the delimited string */
5799 PL_multi_end = PL_curcop->cop_line;
5802 /* if we allocated too much space, give some back */
5803 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5804 SvLEN_set(sv, SvCUR(sv) + 1);
5805 Renew(SvPVX(sv), SvLEN(sv), char);
5808 /* decide whether this is the first or second quoted string we've read
5821 takes: pointer to position in buffer
5822 returns: pointer to new position in buffer
5823 side-effects: builds ops for the constant in yylval.op
5825 Read a number in any of the formats that Perl accepts:
5827 0(x[0-7A-F]+)|([0-7]+)
5828 [\d_]+(\.[\d_]*)?[Ee](\d+)
5830 Underbars (_) are allowed in decimal numbers. If -w is on,
5831 underbars before a decimal point must be at three digit intervals.
5833 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5836 If it reads a number without a decimal point or an exponent, it will
5837 try converting the number to an integer and see if it can do so
5838 without loss of precision.
5842 scan_num(char *start)
5844 register char *s = start; /* current position in buffer */
5845 register char *d; /* destination in temp buffer */
5846 register char *e; /* end of temp buffer */
5847 I32 tryiv; /* used to see if it can be an int */
5848 double value; /* number read, as a double */
5849 SV *sv; /* place to put the converted number */
5850 I32 floatit; /* boolean: int or float? */
5851 char *lastub = 0; /* position of last underbar */
5852 static char number_too_long[] = "Number too long";
5854 /* We use the first character to decide what type of number this is */
5858 croak("panic: scan_num");
5860 /* if it starts with a 0, it could be an octal number, a decimal in
5861 0.13 disguise, or a hexadecimal number.
5866 u holds the "number so far"
5867 shift the power of 2 of the base (hex == 4, octal == 3)
5868 overflowed was the number more than we can hold?
5870 Shift is used when we add a digit. It also serves as an "are
5871 we in octal or hex?" indicator to disallow hex characters when
5876 bool overflowed = FALSE;
5883 /* check for a decimal in disguise */
5884 else if (s[1] == '.')
5886 /* so it must be octal */
5891 /* read the rest of the octal number */
5893 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5897 /* if we don't mention it, we're done */
5906 /* 8 and 9 are not octal */
5909 yyerror("Illegal octal digit");
5913 case '0': case '1': case '2': case '3': case '4':
5914 case '5': case '6': case '7':
5915 b = *s++ & 15; /* ASCII digit -> value of digit */
5919 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5920 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5921 /* make sure they said 0x */
5926 /* Prepare to put the digit we have onto the end
5927 of the number so far. We check for overflows.
5931 n = u << shift; /* make room for the digit */
5932 if (!overflowed && (n >> shift) != u
5933 && !(PL_hints & HINT_NEW_BINARY)) {
5934 warn("Integer overflow in %s number",
5935 (shift == 4) ? "hex" : "octal");
5938 u = n | b; /* add the digit to the end */
5943 /* if we get here, we had success: make a scalar value from
5949 if ( PL_hints & HINT_NEW_BINARY)
5950 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5955 handle decimal numbers.
5956 we're also sent here when we read a 0 as the first digit
5958 case '1': case '2': case '3': case '4': case '5':
5959 case '6': case '7': case '8': case '9': case '.':
5962 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5965 /* read next group of digits and _ and copy into d */
5966 while (isDIGIT(*s) || *s == '_') {
5967 /* skip underscores, checking for misplaced ones
5971 dTHR; /* only for ckWARN */
5972 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
5973 warner(WARN_SYNTAX, "Misplaced _ in number");
5977 /* check for end of fixed-length buffer */
5979 croak(number_too_long);
5980 /* if we're ok, copy the character */
5985 /* final misplaced underbar check */
5986 if (lastub && s - lastub != 3) {
5988 if (ckWARN(WARN_SYNTAX))
5989 warner(WARN_SYNTAX, "Misplaced _ in number");
5992 /* read a decimal portion if there is one. avoid
5993 3..5 being interpreted as the number 3. followed
5996 if (*s == '.' && s[1] != '.') {
6000 /* copy, ignoring underbars, until we run out of
6001 digits. Note: no misplaced underbar checks!
6003 for (; isDIGIT(*s) || *s == '_'; s++) {
6004 /* fixed length buffer check */
6006 croak(number_too_long);
6012 /* read exponent part, if present */
6013 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6017 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6018 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6020 /* allow positive or negative exponent */
6021 if (*s == '+' || *s == '-')
6024 /* read digits of exponent (no underbars :-) */
6025 while (isDIGIT(*s)) {
6027 croak(number_too_long);
6032 /* terminate the string */
6035 /* make an sv from the string */
6037 /* reset numeric locale in case we were earlier left in Swaziland */
6038 SET_NUMERIC_STANDARD();
6039 value = atof(PL_tokenbuf);
6042 See if we can make do with an integer value without loss of
6043 precision. We use I_V to cast to an int, because some
6044 compilers have issues. Then we try casting it back and see
6045 if it was the same. We only do this if we know we
6046 specifically read an integer.
6048 Note: if floatit is true, then we don't need to do the
6052 if (!floatit && (double)tryiv == value)
6053 sv_setiv(sv, tryiv);
6055 sv_setnv(sv, value);
6056 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6057 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6058 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6062 /* make the op for the constant and return */
6064 yylval.opval = newSVOP(OP_CONST, 0, sv);
6070 scan_formline(register char *s)
6075 SV *stuff = newSVpv("",0);
6076 bool needargs = FALSE;
6079 if (*s == '.' || *s == '}') {
6081 for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
6085 if (PL_in_eval && !PL_rsfp) {
6086 eol = strchr(s,'\n');
6091 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6093 for (t = s; t < eol; t++) {
6094 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6096 goto enough; /* ~~ must be first line in formline */
6098 if (*t == '@' || *t == '^')
6101 sv_catpvn(stuff, s, eol-s);
6105 s = filter_gets(PL_linestr, PL_rsfp, 0);
6106 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6107 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6110 yyerror("Format not terminated");
6120 PL_lex_state = LEX_NORMAL;
6121 PL_nextval[PL_nexttoke].ival = 0;
6125 PL_lex_state = LEX_FORMLINE;
6126 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6128 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6132 SvREFCNT_dec(stuff);
6133 PL_lex_formbrack = 0;
6144 PL_cshlen = strlen(PL_cshname);
6149 start_subparse(I32 is_format, U32 flags)
6152 I32 oldsavestack_ix = PL_savestack_ix;
6153 CV* outsidecv = PL_compcv;
6157 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6159 save_I32(&PL_subline);
6160 save_item(PL_subname);
6162 SAVESPTR(PL_curpad);
6163 SAVESPTR(PL_comppad);
6164 SAVESPTR(PL_comppad_name);
6165 SAVESPTR(PL_compcv);
6166 SAVEI32(PL_comppad_name_fill);
6167 SAVEI32(PL_min_intro_pending);
6168 SAVEI32(PL_max_intro_pending);
6169 SAVEI32(PL_pad_reset_pending);
6171 PL_compcv = (CV*)NEWSV(1104,0);
6172 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6173 CvFLAGS(PL_compcv) |= flags;
6175 PL_comppad = newAV();
6176 av_push(PL_comppad, Nullsv);
6177 PL_curpad = AvARRAY(PL_comppad);
6178 PL_comppad_name = newAV();
6179 PL_comppad_name_fill = 0;
6180 PL_min_intro_pending = 0;
6182 PL_subline = PL_curcop->cop_line;
6184 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6185 PL_curpad[0] = (SV*)newAV();
6186 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6187 #endif /* USE_THREADS */
6189 comppadlist = newAV();
6190 AvREAL_off(comppadlist);
6191 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6192 av_store(comppadlist, 1, (SV*)PL_comppad);
6194 CvPADLIST(PL_compcv) = comppadlist;
6195 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6197 CvOWNER(PL_compcv) = 0;
6198 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6199 MUTEX_INIT(CvMUTEXP(PL_compcv));
6200 #endif /* USE_THREADS */
6202 return oldsavestack_ix;
6221 char *context = NULL;
6225 if (!yychar || (yychar == ';' && !PL_rsfp))
6227 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6228 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6229 while (isSPACE(*PL_oldoldbufptr))
6231 context = PL_oldoldbufptr;
6232 contlen = PL_bufptr - PL_oldoldbufptr;
6234 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6235 PL_oldbufptr != PL_bufptr) {
6236 while (isSPACE(*PL_oldbufptr))
6238 context = PL_oldbufptr;
6239 contlen = PL_bufptr - PL_oldbufptr;
6241 else if (yychar > 255)
6242 where = "next token ???";
6243 else if ((yychar & 127) == 127) {
6244 if (PL_lex_state == LEX_NORMAL ||
6245 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6246 where = "at end of line";
6247 else if (PL_lex_inpat)
6248 where = "within pattern";
6250 where = "within string";
6253 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6255 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6256 else if (isPRINT_LC(yychar))
6257 sv_catpvf(where_sv, "%c", yychar);
6259 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6260 where = SvPVX(where_sv);
6262 msg = sv_2mortal(newSVpv(s, 0));
6263 sv_catpvf(msg, " at %_ line %ld, ",
6264 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6266 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6268 sv_catpvf(msg, "%s\n", where);
6269 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6271 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6272 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6277 else if (PL_in_eval)
6278 sv_catsv(ERRSV, msg);
6280 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6281 if (++PL_error_count >= 10)
6282 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6284 PL_in_my_stash = Nullhv;