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 min; /* first character in range */
908 I32 max; /* last character in range */
910 i = d - SvPVX(sv); /* remember current offset */
911 SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
912 d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
913 d -= 2; /* eat the first char and the - */
915 min = (U8)*d; /* first char in range */
916 max = (U8)d[1]; /* last char in range */
919 if ((isLOWER(min) && isLOWER(max)) ||
920 (isUPPER(min) && isUPPER(max))) {
922 for (i = min; i <= max; i++)
926 for (i = min; i <= max; i++)
933 for (i = min; i <= max; i++)
936 /* mark the range as done, and continue */
941 /* range begins (ignore - as first or last char) */
942 else if (*s == '-' && s+1 < send && s != start) {
944 *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */
953 /* if we get here, we're not doing a transliteration */
955 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
956 except for the last char, which will be done separately. */
957 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
959 while (s < send && *s != ')')
961 } else if (s[2] == '{'
962 || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
964 char *regparse = s + (s[2] == '{' ? 3 : 4);
967 while (count && (c = *regparse)) {
968 if (c == '\\' && regparse[1])
976 if (*regparse != ')')
977 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
983 /* likewise skip #-initiated comments in //x patterns */
984 else if (*s == '#' && PL_lex_inpat &&
985 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
986 while (s+1 < send && *s != '\n')
990 /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
991 else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
994 /* check for embedded scalars. only stop if we're sure it's a
997 else if (*s == '$') {
998 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1000 if (s + 1 < send && !strchr("()| \n\t", s[1]))
1001 break; /* in regexp, $ might be tail anchor */
1004 /* (now in tr/// code again) */
1006 if (*s & 0x80 && thisutf) {
1007 dTHR; /* only for ckWARN */
1008 if (ckWARN(WARN_UTF8)) {
1009 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1019 if (*s == '\\' && s+1 < send) {
1022 /* some backslashes we leave behind */
1023 if (*s && strchr(leaveit, *s)) {
1029 /* deprecate \1 in strings and substitution replacements */
1030 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1031 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1033 dTHR; /* only for ckWARN */
1034 if (ckWARN(WARN_SYNTAX))
1035 warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1040 /* string-change backslash escapes */
1041 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1046 /* if we get here, it's either a quoted -, or a digit */
1049 /* quoted - in transliterations */
1051 if (PL_lex_inwhat == OP_TRANS) {
1056 /* default action is to copy the quoted character */
1061 /* \132 indicates an octal constant */
1062 case '0': case '1': case '2': case '3':
1063 case '4': case '5': case '6': case '7':
1064 *d++ = scan_oct(s, 3, &len);
1068 /* \x24 indicates a hex constant */
1072 char* e = strchr(s, '}');
1075 yyerror("Missing right brace on \\x{}");
1078 if (ckWARN(WARN_UTF8))
1080 "Use of \\x{} without utf8 declaration");
1082 /* note: utf always shorter than hex */
1083 d = (char*)uv_to_utf8((U8*)d,
1084 scan_hex(s + 1, e - s - 1, &len));
1089 UV uv = (UV)scan_hex(s, 2, &len);
1090 if (utf && PL_lex_inwhat == OP_TRANS &&
1091 utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1093 d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */
1096 if (uv >= 127 && UTF) {
1098 if (ckWARN(WARN_UTF8))
1100 "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1109 /* \c is a control character */
1123 /* printf-style backslashes, formfeeds, newlines, etc */
1149 } /* end if (backslash) */
1152 } /* while loop to process each character */
1154 /* terminate the string and set up the sv */
1156 SvCUR_set(sv, d - SvPVX(sv));
1159 /* shrink the sv if we allocated more than we used */
1160 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1161 SvLEN_set(sv, SvCUR(sv) + 1);
1162 Renew(SvPVX(sv), SvLEN(sv), char);
1165 /* return the substring (via yylval) only if we parsed anything */
1166 if (s > PL_bufptr) {
1167 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1168 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1170 ( PL_lex_inwhat == OP_TRANS
1172 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1175 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1181 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1183 intuit_more(register char *s)
1185 if (PL_lex_brackets)
1187 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1189 if (*s != '{' && *s != '[')
1194 /* In a pattern, so maybe we have {n,m}. */
1211 /* On the other hand, maybe we have a character class */
1214 if (*s == ']' || *s == '^')
1217 int weight = 2; /* let's weigh the evidence */
1219 unsigned char un_char = 255, last_un_char;
1220 char *send = strchr(s,']');
1221 char tmpbuf[sizeof PL_tokenbuf * 4];
1223 if (!send) /* has to be an expression */
1226 Zero(seen,256,char);
1229 else if (isDIGIT(*s)) {
1231 if (isDIGIT(s[1]) && s[2] == ']')
1237 for (; s < send; s++) {
1238 last_un_char = un_char;
1239 un_char = (unsigned char)*s;
1244 weight -= seen[un_char] * 10;
1245 if (isALNUM(s[1])) {
1246 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1247 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1252 else if (*s == '$' && s[1] &&
1253 strchr("[#!%*<>()-=",s[1])) {
1254 if (/*{*/ strchr("])} =",s[2]))
1263 if (strchr("wds]",s[1]))
1265 else if (seen['\''] || seen['"'])
1267 else if (strchr("rnftbxcav",s[1]))
1269 else if (isDIGIT(s[1])) {
1271 while (s[1] && isDIGIT(s[1]))
1281 if (strchr("aA01! ",last_un_char))
1283 if (strchr("zZ79~",s[1]))
1285 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1286 weight -= 5; /* cope with negative subscript */
1289 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1290 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1295 if (keyword(tmpbuf, d - tmpbuf))
1298 if (un_char == last_un_char + 1)
1300 weight -= seen[un_char];
1305 if (weight >= 0) /* probably a character class */
1313 intuit_method(char *start, GV *gv)
1315 char *s = start + (*start == '$');
1316 char tmpbuf[sizeof PL_tokenbuf];
1324 if ((cv = GvCVu(gv))) {
1325 char *proto = SvPVX(cv);
1335 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1336 if (*start == '$') {
1337 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1342 return *s == '(' ? FUNCMETH : METHOD;
1344 if (!keyword(tmpbuf, len)) {
1345 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1350 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1351 if (indirgv && GvCVu(indirgv))
1353 /* filehandle or package name makes it a method */
1354 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1356 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1357 return 0; /* no assumptions -- "=>" quotes bearword */
1359 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1361 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1365 return *s == '(' ? FUNCMETH : METHOD;
1375 char *pdb = PerlEnv_getenv("PERL5DB");
1379 SETERRNO(0,SS$_NORMAL);
1380 return "BEGIN { require 'perl5db.pl' }";
1386 /* Encoded script support. filter_add() effectively inserts a
1387 * 'pre-processing' function into the current source input stream.
1388 * Note that the filter function only applies to the current source file
1389 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1391 * The datasv parameter (which may be NULL) can be used to pass
1392 * private data to this instance of the filter. The filter function
1393 * can recover the SV using the FILTER_DATA macro and use it to
1394 * store private buffers and state information.
1396 * The supplied datasv parameter is upgraded to a PVIO type
1397 * and the IoDIRP field is used to store the function pointer.
1398 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1399 * private use must be set using malloc'd pointers.
1401 static int filter_debug = 0;
1404 filter_add(filter_t funcp, SV *datasv)
1406 if (!funcp){ /* temporary handy debugging hack to be deleted */
1407 filter_debug = atoi((char*)datasv);
1410 if (!PL_rsfp_filters)
1411 PL_rsfp_filters = newAV();
1413 datasv = NEWSV(255,0);
1414 if (!SvUPGRADE(datasv, SVt_PVIO))
1415 die("Can't upgrade filter_add data to SVt_PVIO");
1416 IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1418 warn("filter_add func %p (%s)", funcp, SvPV(datasv,PL_na));
1419 av_unshift(PL_rsfp_filters, 1);
1420 av_store(PL_rsfp_filters, 0, datasv) ;
1425 /* Delete most recently added instance of this filter function. */
1427 filter_del(filter_t funcp)
1430 warn("filter_del func %p", funcp);
1431 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1433 /* if filter is on top of stack (usual case) just pop it off */
1434 if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (void*)funcp){
1435 sv_free(av_pop(PL_rsfp_filters));
1439 /* we need to search for the correct entry and clear it */
1440 die("filter_del can only delete in reverse order (currently)");
1444 /* Invoke the n'th filter function for the current rsfp. */
1446 filter_read(int idx, SV *buf_sv, int maxlen)
1449 /* 0 = read one text line */
1454 if (!PL_rsfp_filters)
1456 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
1457 /* Provide a default input filter to make life easy. */
1458 /* Note that we append to the line. This is handy. */
1460 warn("filter_read %d: from rsfp\n", idx);
1464 int old_len = SvCUR(buf_sv) ;
1466 /* ensure buf_sv is large enough */
1467 SvGROW(buf_sv, old_len + maxlen) ;
1468 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1469 if (PerlIO_error(PL_rsfp))
1470 return -1; /* error */
1472 return 0 ; /* end of file */
1474 SvCUR_set(buf_sv, old_len + len) ;
1477 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1478 if (PerlIO_error(PL_rsfp))
1479 return -1; /* error */
1481 return 0 ; /* end of file */
1484 return SvCUR(buf_sv);
1486 /* Skip this filter slot if filter has been deleted */
1487 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1489 warn("filter_read %d: skipped (filter deleted)\n", idx);
1490 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1492 /* Get function pointer hidden within datasv */
1493 funcp = (filter_t)IoDIRP(datasv);
1495 warn("filter_read %d: via function %p (%s)\n",
1496 idx, funcp, SvPV(datasv,PL_na));
1497 /* Call function. The function is expected to */
1498 /* call "FILTER_READ(idx+1, buf_sv)" first. */
1499 /* Return: <0:error, =0:eof, >0:not eof */
1500 return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1504 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1507 if (!PL_rsfp_filters) {
1508 filter_add(win32_textfilter,NULL);
1511 if (PL_rsfp_filters) {
1514 SvCUR_set(sv, 0); /* start with empty line */
1515 if (FILTER_READ(0, sv, 0) > 0)
1516 return ( SvPVX(sv) ) ;
1521 return (sv_gets(sv, fp, append));
1526 static char* exp_name[] =
1527 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1530 EXT int yychar; /* last token */
1535 Works out what to call the token just pulled out of the input
1536 stream. The yacc parser takes care of taking the ops we return and
1537 stitching them into a tree.
1543 if read an identifier
1544 if we're in a my declaration
1545 croak if they tried to say my($foo::bar)
1546 build the ops for a my() declaration
1547 if it's an access to a my() variable
1548 are we in a sort block?
1549 croak if my($a); $a <=> $b
1550 build ops for access to a my() variable
1551 if in a dq string, and they've said @foo and we can't find @foo
1553 build ops for a bareword
1554 if we already built the token before, use it.
1568 /* check if there's an identifier for us to look at */
1569 if (PL_pending_ident) {
1570 /* pit holds the identifier we read and pending_ident is reset */
1571 char pit = PL_pending_ident;
1572 PL_pending_ident = 0;
1574 /* if we're in a my(), we can't allow dynamics here.
1575 $foo'bar has already been turned into $foo::bar, so
1576 just check for colons.
1578 if it's a legal name, the OP is a PADANY.
1581 if (strchr(PL_tokenbuf,':'))
1582 croak(no_myglob,PL_tokenbuf);
1584 yylval.opval = newOP(OP_PADANY, 0);
1585 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1590 build the ops for accesses to a my() variable.
1592 Deny my($a) or my($b) in a sort block, *if* $a or $b is
1593 then used in a comparison. This catches most, but not
1594 all cases. For instance, it catches
1595 sort { my($a); $a <=> $b }
1597 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1598 (although why you'd do that is anyone's guess).
1601 if (!strchr(PL_tokenbuf,':')) {
1603 /* Check for single character per-thread SVs */
1604 if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1605 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1606 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1608 yylval.opval = newOP(OP_THREADSV, 0);
1609 yylval.opval->op_targ = tmp;
1612 #endif /* USE_THREADS */
1613 if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1614 /* if it's a sort block and they're naming $a or $b */
1615 if (PL_last_lop_op == OP_SORT &&
1616 PL_tokenbuf[0] == '$' &&
1617 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1620 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1621 d < PL_bufend && *d != '\n';
1624 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1625 croak("Can't use \"my %s\" in sort comparison",
1631 yylval.opval = newOP(OP_PADANY, 0);
1632 yylval.opval->op_targ = tmp;
1638 Whine if they've said @foo in a doublequoted string,
1639 and @foo isn't a variable we can find in the symbol
1642 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1643 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1644 if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1645 yyerror(form("In string, %s now must be written as \\%s",
1646 PL_tokenbuf, PL_tokenbuf));
1649 /* build ops for a bareword */
1650 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1651 yylval.opval->op_private = OPpCONST_ENTERED;
1652 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1653 ((PL_tokenbuf[0] == '$') ? SVt_PV
1654 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1659 /* no identifier pending identification */
1661 switch (PL_lex_state) {
1663 case LEX_NORMAL: /* Some compilers will produce faster */
1664 case LEX_INTERPNORMAL: /* code if we comment these out. */
1668 /* when we're already built the next token, just pull it out the queue */
1671 yylval = PL_nextval[PL_nexttoke];
1673 PL_lex_state = PL_lex_defer;
1674 PL_expect = PL_lex_expect;
1675 PL_lex_defer = LEX_NORMAL;
1677 return(PL_nexttype[PL_nexttoke]);
1679 /* interpolated case modifiers like \L \U, including \Q and \E.
1680 when we get here, PL_bufptr is at the \
1682 case LEX_INTERPCASEMOD:
1684 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1685 croak("panic: INTERPCASEMOD");
1687 /* handle \E or end of string */
1688 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1692 if (PL_lex_casemods) {
1693 oldmod = PL_lex_casestack[--PL_lex_casemods];
1694 PL_lex_casestack[PL_lex_casemods] = '\0';
1696 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1698 PL_lex_state = LEX_INTERPCONCAT;
1702 if (PL_bufptr != PL_bufend)
1704 PL_lex_state = LEX_INTERPCONCAT;
1709 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1710 tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
1711 if (strchr("LU", *s) &&
1712 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1714 PL_lex_casestack[--PL_lex_casemods] = '\0';
1717 if (PL_lex_casemods > 10) {
1718 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1719 if (newlb != PL_lex_casestack) {
1721 PL_lex_casestack = newlb;
1724 PL_lex_casestack[PL_lex_casemods++] = *s;
1725 PL_lex_casestack[PL_lex_casemods] = '\0';
1726 PL_lex_state = LEX_INTERPCONCAT;
1727 PL_nextval[PL_nexttoke].ival = 0;
1730 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1732 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1734 PL_nextval[PL_nexttoke].ival = OP_LC;
1736 PL_nextval[PL_nexttoke].ival = OP_UC;
1738 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1740 croak("panic: yylex");
1743 if (PL_lex_starts) {
1752 case LEX_INTERPPUSH:
1753 return sublex_push();
1755 case LEX_INTERPSTART:
1756 if (PL_bufptr == PL_bufend)
1757 return sublex_done();
1759 PL_lex_dojoin = (*PL_bufptr == '@');
1760 PL_lex_state = LEX_INTERPNORMAL;
1761 if (PL_lex_dojoin) {
1762 PL_nextval[PL_nexttoke].ival = 0;
1765 PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1766 PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1767 force_next(PRIVATEREF);
1769 force_ident("\"", '$');
1770 #endif /* USE_THREADS */
1771 PL_nextval[PL_nexttoke].ival = 0;
1773 PL_nextval[PL_nexttoke].ival = 0;
1775 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
1778 if (PL_lex_starts++) {
1784 case LEX_INTERPENDMAYBE:
1785 if (intuit_more(PL_bufptr)) {
1786 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
1792 if (PL_lex_dojoin) {
1793 PL_lex_dojoin = FALSE;
1794 PL_lex_state = LEX_INTERPCONCAT;
1798 case LEX_INTERPCONCAT:
1800 if (PL_lex_brackets)
1801 croak("panic: INTERPCONCAT");
1803 if (PL_bufptr == PL_bufend)
1804 return sublex_done();
1806 if (SvIVX(PL_linestr) == '\'') {
1807 SV *sv = newSVsv(PL_linestr);
1810 else if ( PL_hints & HINT_NEW_RE )
1811 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1812 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1816 s = scan_const(PL_bufptr);
1818 PL_lex_state = LEX_INTERPCASEMOD;
1820 PL_lex_state = LEX_INTERPSTART;
1823 if (s != PL_bufptr) {
1824 PL_nextval[PL_nexttoke] = yylval;
1827 if (PL_lex_starts++)
1837 PL_lex_state = LEX_NORMAL;
1838 s = scan_formline(PL_bufptr);
1839 if (!PL_lex_formbrack)
1845 PL_oldoldbufptr = PL_oldbufptr;
1848 PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1855 * Note: we try to be careful never to call the isXXX_utf8() functions unless we're
1856 * pretty sure we've seen the beginning of a UTF-8 character (that is, the two high
1857 * bits are set). Otherwise we risk loading in the heavy-duty SWASHINIT and SWASHGET
1858 * routines unnecessarily. You will see this not just here but throughout this file.
1860 if (UTF && (*s & 0xc0) == 0x80) {
1861 if (isIDFIRST_utf8((U8*)s))
1864 croak("Unrecognized character \\x%02X", *s & 255);
1867 goto fake_eof; /* emulate EOF on ^D or ^Z */
1872 if (PL_lex_brackets)
1873 yyerror("Missing right bracket");
1876 if (s++ < PL_bufend)
1877 goto retry; /* ignore stray nulls */
1880 if (!PL_in_eval && !PL_preambled) {
1881 PL_preambled = TRUE;
1882 sv_setpv(PL_linestr,incl_perldb());
1883 if (SvCUR(PL_linestr))
1884 sv_catpv(PL_linestr,";");
1886 while(AvFILLp(PL_preambleav) >= 0) {
1887 SV *tmpsv = av_shift(PL_preambleav);
1888 sv_catsv(PL_linestr, tmpsv);
1889 sv_catpv(PL_linestr, ";");
1892 sv_free((SV*)PL_preambleav);
1893 PL_preambleav = NULL;
1895 if (PL_minus_n || PL_minus_p) {
1896 sv_catpv(PL_linestr, "LINE: while (<>) {");
1898 sv_catpv(PL_linestr,"chomp;");
1900 GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1902 GvIMPORTED_AV_on(gv);
1904 if (strchr("/'\"", *PL_splitstr)
1905 && strchr(PL_splitstr + 1, *PL_splitstr))
1906 sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1909 s = "'~#\200\1'"; /* surely one char is unused...*/
1910 while (s[1] && strchr(PL_splitstr, *s)) s++;
1912 sv_catpvf(PL_linestr, "@F=split(%s%c",
1913 "q" + (delim == '\''), delim);
1914 for (s = PL_splitstr; *s; s++) {
1916 sv_catpvn(PL_linestr, "\\", 1);
1917 sv_catpvn(PL_linestr, s, 1);
1919 sv_catpvf(PL_linestr, "%c);", delim);
1923 sv_catpv(PL_linestr,"@F=split(' ');");
1926 sv_catpv(PL_linestr, "\n");
1927 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1928 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1929 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1930 SV *sv = NEWSV(85,0);
1932 sv_upgrade(sv, SVt_PVMG);
1933 sv_setsv(sv,PL_linestr);
1934 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1939 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1942 if (PL_preprocess && !PL_in_eval)
1943 (void)PerlProc_pclose(PL_rsfp);
1944 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1945 PerlIO_clearerr(PL_rsfp);
1947 (void)PerlIO_close(PL_rsfp);
1949 PL_doextract = FALSE;
1951 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1952 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1953 sv_catpv(PL_linestr,";}");
1954 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1955 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1956 PL_minus_n = PL_minus_p = 0;
1959 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1960 sv_setpv(PL_linestr,"");
1961 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
1964 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1965 PL_doextract = FALSE;
1967 /* Incest with pod. */
1968 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1969 sv_setpv(PL_linestr, "");
1970 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1971 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1972 PL_doextract = FALSE;
1976 } while (PL_doextract);
1977 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
1978 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1979 SV *sv = NEWSV(85,0);
1981 sv_upgrade(sv, SVt_PVMG);
1982 sv_setsv(sv,PL_linestr);
1983 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1985 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1986 if (PL_curcop->cop_line == 1) {
1987 while (s < PL_bufend && isSPACE(*s))
1989 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
1993 if (*s == '#' && *(s+1) == '!')
1995 #ifdef ALTERNATE_SHEBANG
1997 static char as[] = ALTERNATE_SHEBANG;
1998 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
1999 d = s + (sizeof(as) - 1);
2001 #endif /* ALTERNATE_SHEBANG */
2010 while (*d && !isSPACE(*d))
2014 #ifdef ARG_ZERO_IS_SCRIPT
2015 if (ipathend > ipath) {
2017 * HP-UX (at least) sets argv[0] to the script name,
2018 * which makes $^X incorrect. And Digital UNIX and Linux,
2019 * at least, set argv[0] to the basename of the Perl
2020 * interpreter. So, having found "#!", we'll set it right.
2022 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2023 assert(SvPOK(x) || SvGMAGICAL(x));
2024 if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2025 sv_setpvn(x, ipath, ipathend - ipath);
2028 TAINT_NOT; /* $^X is always tainted, but that's OK */
2030 #endif /* ARG_ZERO_IS_SCRIPT */
2035 d = instr(s,"perl -");
2037 d = instr(s,"perl");
2038 #ifdef ALTERNATE_SHEBANG
2040 * If the ALTERNATE_SHEBANG on this system starts with a
2041 * character that can be part of a Perl expression, then if
2042 * we see it but not "perl", we're probably looking at the
2043 * start of Perl code, not a request to hand off to some
2044 * other interpreter. Similarly, if "perl" is there, but
2045 * not in the first 'word' of the line, we assume the line
2046 * contains the start of the Perl program.
2048 if (d && *s != '#') {
2050 while (*c && !strchr("; \t\r\n\f\v#", *c))
2053 d = Nullch; /* "perl" not in first word; ignore */
2055 *s = '#'; /* Don't try to parse shebang line */
2057 #endif /* ALTERNATE_SHEBANG */
2062 !instr(s,"indir") &&
2063 instr(PL_origargv[0],"perl"))
2069 while (s < PL_bufend && isSPACE(*s))
2071 if (s < PL_bufend) {
2072 Newz(899,newargv,PL_origargc+3,char*);
2074 while (s < PL_bufend && !isSPACE(*s))
2077 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2080 newargv = PL_origargv;
2082 execv(ipath, newargv);
2083 croak("Can't exec %s", ipath);
2086 U32 oldpdb = PL_perldb;
2087 bool oldn = PL_minus_n;
2088 bool oldp = PL_minus_p;
2090 while (*d && !isSPACE(*d)) d++;
2091 while (*d == ' ' || *d == '\t') d++;
2095 if (*d == 'M' || *d == 'm') {
2097 while (*d && !isSPACE(*d)) d++;
2098 croak("Too late for \"-%.*s\" option",
2101 d = moreswitches(d);
2103 if (PERLDB_LINE && !oldpdb ||
2104 ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2105 /* if we have already added "LINE: while (<>) {",
2106 we must not do it again */
2108 sv_setpv(PL_linestr, "");
2109 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2110 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2111 PL_preambled = FALSE;
2113 (void)gv_fetchfile(PL_origfilename);
2120 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2122 PL_lex_state = LEX_FORMLINE;
2127 #ifdef PERL_STRICT_CR
2128 warn("Illegal character \\%03o (carriage return)", '\r');
2130 "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2132 case ' ': case '\t': case '\f': case 013:
2137 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2139 while (s < d && *s != '\n')
2144 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2146 PL_lex_state = LEX_FORMLINE;
2156 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2161 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2164 if (strnEQ(s,"=>",2)) {
2165 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2166 OPERATOR('-'); /* unary minus */
2168 PL_last_uni = PL_oldbufptr;
2169 PL_last_lop_op = OP_FTEREAD; /* good enough */
2171 case 'r': FTST(OP_FTEREAD);
2172 case 'w': FTST(OP_FTEWRITE);
2173 case 'x': FTST(OP_FTEEXEC);
2174 case 'o': FTST(OP_FTEOWNED);
2175 case 'R': FTST(OP_FTRREAD);
2176 case 'W': FTST(OP_FTRWRITE);
2177 case 'X': FTST(OP_FTREXEC);
2178 case 'O': FTST(OP_FTROWNED);
2179 case 'e': FTST(OP_FTIS);
2180 case 'z': FTST(OP_FTZERO);
2181 case 's': FTST(OP_FTSIZE);
2182 case 'f': FTST(OP_FTFILE);
2183 case 'd': FTST(OP_FTDIR);
2184 case 'l': FTST(OP_FTLINK);
2185 case 'p': FTST(OP_FTPIPE);
2186 case 'S': FTST(OP_FTSOCK);
2187 case 'u': FTST(OP_FTSUID);
2188 case 'g': FTST(OP_FTSGID);
2189 case 'k': FTST(OP_FTSVTX);
2190 case 'b': FTST(OP_FTBLK);
2191 case 'c': FTST(OP_FTCHR);
2192 case 't': FTST(OP_FTTTY);
2193 case 'T': FTST(OP_FTTEXT);
2194 case 'B': FTST(OP_FTBINARY);
2195 case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2196 case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2197 case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2199 croak("Unrecognized file test: -%c", (int)tmp);
2206 if (PL_expect == XOPERATOR)
2211 else if (*s == '>') {
2214 if (isIDFIRST(*s)) {
2215 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2223 if (PL_expect == XOPERATOR)
2226 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2228 OPERATOR('-'); /* unary minus */
2235 if (PL_expect == XOPERATOR)
2240 if (PL_expect == XOPERATOR)
2243 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2249 if (PL_expect != XOPERATOR) {
2250 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2251 PL_expect = XOPERATOR;
2252 force_ident(PL_tokenbuf, '*');
2265 if (PL_expect == XOPERATOR) {
2269 PL_tokenbuf[0] = '%';
2270 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2271 if (!PL_tokenbuf[1]) {
2273 yyerror("Final % should be \\% or %name");
2276 PL_pending_ident = '%';
2298 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2299 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
2304 if (PL_curcop->cop_line < PL_copline)
2305 PL_copline = PL_curcop->cop_line;
2316 if (PL_lex_brackets <= 0)
2317 yyerror("Unmatched right bracket");
2320 if (PL_lex_state == LEX_INTERPNORMAL) {
2321 if (PL_lex_brackets == 0) {
2322 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2323 PL_lex_state = LEX_INTERPEND;
2330 if (PL_lex_brackets > 100) {
2331 char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2332 if (newlb != PL_lex_brackstack) {
2334 PL_lex_brackstack = newlb;
2337 switch (PL_expect) {
2339 if (PL_lex_formbrack) {
2343 if (PL_oldoldbufptr == PL_last_lop)
2344 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2346 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2347 OPERATOR(HASHBRACK);
2349 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2352 PL_tokenbuf[0] = '\0';
2353 if (d < PL_bufend && *d == '-') {
2354 PL_tokenbuf[0] = '-';
2356 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2359 if (d < PL_bufend && isIDFIRST(*d)) {
2360 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2362 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2365 char minus = (PL_tokenbuf[0] == '-');
2366 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2373 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2377 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2382 if (PL_oldoldbufptr == PL_last_lop)
2383 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2385 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2388 OPERATOR(HASHBRACK);
2389 /* This hack serves to disambiguate a pair of curlies
2390 * as being a block or an anon hash. Normally, expectation
2391 * determines that, but in cases where we're not in a
2392 * position to expect anything in particular (like inside
2393 * eval"") we have to resolve the ambiguity. This code
2394 * covers the case where the first term in the curlies is a
2395 * quoted string. Most other cases need to be explicitly
2396 * disambiguated by prepending a `+' before the opening
2397 * curly in order to force resolution as an anon hash.
2399 * XXX should probably propagate the outer expectation
2400 * into eval"" to rely less on this hack, but that could
2401 * potentially break current behavior of eval"".
2405 if (*s == '\'' || *s == '"' || *s == '`') {
2406 /* common case: get past first string, handling escapes */
2407 for (t++; t < PL_bufend && *t != *s;)
2408 if (*t++ == '\\' && (*t == '\\' || *t == *s))
2412 else if (*s == 'q') {
2415 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2416 && !isALNUM(*t)))) {
2418 char open, close, term;
2421 while (t < PL_bufend && isSPACE(*t))
2425 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2429 for (t++; t < PL_bufend; t++) {
2430 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2432 else if (*t == open)
2436 for (t++; t < PL_bufend; t++) {
2437 if (*t == '\\' && t+1 < PL_bufend)
2439 else if (*t == close && --brackets <= 0)
2441 else if (*t == open)
2447 else if (isALPHA(*s)) {
2448 for (t++; t < PL_bufend && isALNUM(*t); t++) ;
2450 while (t < PL_bufend && isSPACE(*t))
2452 /* if comma follows first term, call it an anon hash */
2453 /* XXX it could be a comma expression with loop modifiers */
2454 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2455 || (*t == '=' && t[1] == '>')))
2456 OPERATOR(HASHBRACK);
2457 if (PL_expect == XREF)
2460 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2466 yylval.ival = PL_curcop->cop_line;
2467 if (isSPACE(*s) || *s == '#')
2468 PL_copline = NOLINE; /* invalidate current command line number */
2473 if (PL_lex_brackets <= 0)
2474 yyerror("Unmatched right bracket");
2476 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2477 if (PL_lex_brackets < PL_lex_formbrack)
2478 PL_lex_formbrack = 0;
2479 if (PL_lex_state == LEX_INTERPNORMAL) {
2480 if (PL_lex_brackets == 0) {
2481 if (PL_lex_fakebrack) {
2482 PL_lex_state = LEX_INTERPEND;
2484 return yylex(); /* ignore fake brackets */
2486 if (*s == '-' && s[1] == '>')
2487 PL_lex_state = LEX_INTERPENDMAYBE;
2488 else if (*s != '[' && *s != '{')
2489 PL_lex_state = LEX_INTERPEND;
2492 if (PL_lex_brackets < PL_lex_fakebrack) {
2494 PL_lex_fakebrack = 0;
2495 return yylex(); /* ignore fake brackets */
2505 if (PL_expect == XOPERATOR) {
2506 if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && PL_bufptr == PL_linestart) {
2507 PL_curcop->cop_line--;
2508 warner(WARN_SEMICOLON, warn_nosemi);
2509 PL_curcop->cop_line++;
2514 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2516 PL_expect = XOPERATOR;
2517 force_ident(PL_tokenbuf, '&');
2521 yylval.ival = (OPpENTERSUB_AMPER<<8);
2540 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2541 warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2543 if (PL_expect == XSTATE && isALPHA(tmp) &&
2544 (s == PL_linestart+1 || s[-2] == '\n') )
2546 if (PL_in_eval && !PL_rsfp) {
2551 if (strnEQ(s,"=cut",4)) {
2565 PL_doextract = TRUE;
2568 if (PL_lex_brackets < PL_lex_formbrack) {
2570 #ifdef PERL_STRICT_CR
2571 for (t = s; *t == ' ' || *t == '\t'; t++) ;
2573 for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2575 if (*t == '\n' || *t == '#') {
2593 if (PL_expect != XOPERATOR) {
2594 if (s[1] != '<' && !strchr(s,'>'))
2597 s = scan_heredoc(s);
2599 s = scan_inputsymbol(s);
2600 TERM(sublex_start());
2605 SHop(OP_LEFT_SHIFT);
2619 SHop(OP_RIGHT_SHIFT);
2628 if (PL_expect == XOPERATOR) {
2629 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2632 return ','; /* grandfather non-comma-format format */
2636 if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:+-", s[2]))) {
2637 if (PL_expect == XOPERATOR)
2638 no_op("Array length", PL_bufptr);
2639 PL_tokenbuf[0] = '@';
2640 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2642 if (!PL_tokenbuf[1])
2644 PL_expect = XOPERATOR;
2645 PL_pending_ident = '#';
2649 if (PL_expect == XOPERATOR)
2650 no_op("Scalar", PL_bufptr);
2651 PL_tokenbuf[0] = '$';
2652 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2653 if (!PL_tokenbuf[1]) {
2655 yyerror("Final $ should be \\$ or $name");
2659 /* This kludge not intended to be bulletproof. */
2660 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2661 yylval.opval = newSVOP(OP_CONST, 0,
2662 newSViv((IV)PL_compiling.cop_arybase));
2663 yylval.opval->op_private = OPpCONST_ARYBASE;
2668 if (PL_lex_state == LEX_NORMAL)
2671 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2674 PL_tokenbuf[0] = '@';
2675 if (ckWARN(WARN_SYNTAX)) {
2677 isSPACE(*t) || isALNUM(*t) || *t == '$';
2680 PL_bufptr = skipspace(PL_bufptr);
2681 while (t < PL_bufend && *t != ']')
2684 "Multidimensional syntax %.*s not supported",
2685 (t - PL_bufptr) + 1, PL_bufptr);
2689 else if (*s == '{') {
2690 PL_tokenbuf[0] = '%';
2691 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2692 (t = strchr(s, '}')) && (t = strchr(t, '=')))
2694 char tmpbuf[sizeof PL_tokenbuf];
2696 for (t++; isSPACE(*t); t++) ;
2697 if (isIDFIRST(*t)) {
2698 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2699 if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2701 "You need to quote \"%s\"", tmpbuf);
2707 PL_expect = XOPERATOR;
2708 if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2709 bool islop = (PL_last_lop == PL_oldoldbufptr);
2710 if (!islop || PL_last_lop_op == OP_GREPSTART)
2711 PL_expect = XOPERATOR;
2712 else if (strchr("$@\"'`q", *s))
2713 PL_expect = XTERM; /* e.g. print $fh "foo" */
2714 else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2715 PL_expect = XTERM; /* e.g. print $fh &sub */
2716 else if (isIDFIRST(*s)) {
2717 char tmpbuf[sizeof PL_tokenbuf];
2718 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2719 if (tmp = keyword(tmpbuf, len)) {
2720 /* binary operators exclude handle interpretations */
2732 PL_expect = XTERM; /* e.g. print $fh length() */
2737 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2738 if (gv && GvCVu(gv))
2739 PL_expect = XTERM; /* e.g. print $fh subr() */
2742 else if (isDIGIT(*s))
2743 PL_expect = XTERM; /* e.g. print $fh 3 */
2744 else if (*s == '.' && isDIGIT(s[1]))
2745 PL_expect = XTERM; /* e.g. print $fh .3 */
2746 else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2747 PL_expect = XTERM; /* e.g. print $fh -1 */
2748 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2749 PL_expect = XTERM; /* print $fh <<"EOF" */
2751 PL_pending_ident = '$';
2755 if (PL_expect == XOPERATOR)
2757 PL_tokenbuf[0] = '@';
2758 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2759 if (!PL_tokenbuf[1]) {
2761 yyerror("Final @ should be \\@ or @name");
2764 if (PL_lex_state == LEX_NORMAL)
2766 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2768 PL_tokenbuf[0] = '%';
2770 /* Warn about @ where they meant $. */
2771 if (ckWARN(WARN_SYNTAX)) {
2772 if (*s == '[' || *s == '{') {
2774 while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2776 if (*t == '}' || *t == ']') {
2778 PL_bufptr = skipspace(PL_bufptr);
2780 "Scalar value %.*s better written as $%.*s",
2781 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2786 PL_pending_ident = '@';
2789 case '/': /* may either be division or pattern */
2790 case '?': /* may either be conditional or pattern */
2791 if (PL_expect != XOPERATOR) {
2792 /* Disable warning on "study /blah/" */
2793 if (PL_oldoldbufptr == PL_last_uni
2794 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2795 || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2797 s = scan_pat(s,OP_MATCH);
2798 TERM(sublex_start());
2806 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2807 #ifdef PERL_STRICT_CR
2810 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2812 && (s == PL_linestart || s[-1] == '\n') )
2814 PL_lex_formbrack = 0;
2818 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2824 yylval.ival = OPf_SPECIAL;
2830 if (PL_expect != XOPERATOR)
2835 case '0': case '1': case '2': case '3': case '4':
2836 case '5': case '6': case '7': case '8': case '9':
2838 if (PL_expect == XOPERATOR)
2844 if (PL_expect == XOPERATOR) {
2845 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2848 return ','; /* grandfather non-comma-format format */
2854 missingterm((char*)0);
2855 yylval.ival = OP_CONST;
2856 TERM(sublex_start());
2860 if (PL_expect == XOPERATOR) {
2861 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2864 return ','; /* grandfather non-comma-format format */
2870 missingterm((char*)0);
2871 yylval.ival = OP_CONST;
2872 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2873 if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2874 yylval.ival = OP_STRINGIFY;
2878 TERM(sublex_start());
2882 if (PL_expect == XOPERATOR)
2883 no_op("Backticks",s);
2885 missingterm((char*)0);
2886 yylval.ival = OP_BACKTICK;
2888 TERM(sublex_start());
2892 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2893 warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2895 if (PL_expect == XOPERATOR)
2896 no_op("Backslash",s);
2900 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2939 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2941 /* Some keywords can be followed by any delimiter, including ':' */
2942 tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2943 len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2944 (PL_tokenbuf[0] == 'q' &&
2945 strchr("qwxr", PL_tokenbuf[1]))));
2947 /* x::* is just a word, unless x is "CORE" */
2948 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2952 while (d < PL_bufend && isSPACE(*d))
2953 d++; /* no comments skipped here, or s### is misparsed */
2955 /* Is this a label? */
2956 if (!tmp && PL_expect == XSTATE
2957 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2959 yylval.pval = savepv(PL_tokenbuf);
2964 /* Check for keywords */
2965 tmp = keyword(PL_tokenbuf, len);
2967 /* Is this a word before a => operator? */
2968 if (strnEQ(d,"=>",2)) {
2970 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2971 yylval.opval->op_private = OPpCONST_BARE;
2975 if (tmp < 0) { /* second-class keyword? */
2976 GV *ogv = Nullgv; /* override (winner) */
2977 GV *hgv = Nullgv; /* hidden (loser) */
2978 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2980 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
2983 if (GvIMPORTED_CV(gv))
2985 else if (! CvMETHOD(cv))
2989 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2990 (gv = *gvp) != (GV*)&PL_sv_undef &&
2991 GvCVu(gv) && GvIMPORTED_CV(gv))
2997 tmp = 0; /* overridden by import or by GLOBAL */
3000 && -tmp==KEY_lock /* XXX generalizable kludge */
3001 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3003 tmp = 0; /* any sub overrides "weak" keyword */
3005 else { /* no override */
3009 if (ckWARN(WARN_AMBIGUOUS) && hgv
3010 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3011 warner(WARN_AMBIGUOUS,
3012 "Ambiguous call resolved as CORE::%s(), %s",
3013 GvENAME(hgv), "qualify as such or use &");
3020 default: /* not a keyword */
3023 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3025 /* Get the rest if it looks like a package qualifier */
3027 if (*s == '\'' || *s == ':' && s[1] == ':') {
3029 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3032 croak("Bad name after %s%s", PL_tokenbuf,
3033 *s == '\'' ? "'" : "::");
3037 if (PL_expect == XOPERATOR) {
3038 if (PL_bufptr == PL_linestart) {
3039 PL_curcop->cop_line--;
3040 warner(WARN_SEMICOLON, warn_nosemi);
3041 PL_curcop->cop_line++;
3044 no_op("Bareword",s);
3047 /* Look for a subroutine with this name in current package,
3048 unless name is "Foo::", in which case Foo is a bearword
3049 (and a package name). */
3052 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3054 if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3056 "Bareword \"%s\" refers to nonexistent package",
3059 PL_tokenbuf[len] = '\0';
3066 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3069 /* if we saw a global override before, get the right name */
3072 sv = newSVpv("CORE::GLOBAL::",14);
3073 sv_catpv(sv,PL_tokenbuf);
3076 sv = newSVpv(PL_tokenbuf,0);
3078 /* Presume this is going to be a bareword of some sort. */
3081 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3082 yylval.opval->op_private = OPpCONST_BARE;
3084 /* And if "Foo::", then that's what it certainly is. */
3089 /* See if it's the indirect object for a list operator. */
3091 if (PL_oldoldbufptr &&
3092 PL_oldoldbufptr < PL_bufptr &&
3093 (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3094 /* NO SKIPSPACE BEFORE HERE! */
3096 || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3097 || (PL_last_lop_op == OP_ENTERSUB
3099 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3101 bool immediate_paren = *s == '(';
3103 /* (Now we can afford to cross potential line boundary.) */
3106 /* Two barewords in a row may indicate method call. */
3108 if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
3111 /* If not a declared subroutine, it's an indirect object. */
3112 /* (But it's an indir obj regardless for sort.) */
3114 if ((PL_last_lop_op == OP_SORT ||
3115 (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3116 (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3117 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3122 /* If followed by a paren, it's certainly a subroutine. */
3124 PL_expect = XOPERATOR;
3128 if (gv && GvCVu(gv)) {
3129 for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3130 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3135 PL_nextval[PL_nexttoke].opval = yylval.opval;
3136 PL_expect = XOPERATOR;
3142 /* If followed by var or block, call it a method (unless sub) */
3144 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3145 PL_last_lop = PL_oldbufptr;
3146 PL_last_lop_op = OP_METHOD;
3150 /* If followed by a bareword, see if it looks like indir obj. */
3152 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3155 /* Not a method, so call it a subroutine (if defined) */
3157 if (gv && GvCVu(gv)) {
3159 if (lastchar == '-')
3160 warn("Ambiguous use of -%s resolved as -&%s()",
3161 PL_tokenbuf, PL_tokenbuf);
3162 PL_last_lop = PL_oldbufptr;
3163 PL_last_lop_op = OP_ENTERSUB;
3164 /* Check for a constant sub */
3166 if ((sv = cv_const_sv(cv))) {
3168 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3169 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3170 yylval.opval->op_private = 0;
3174 /* Resolve to GV now. */
3175 op_free(yylval.opval);
3176 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3177 /* Is there a prototype? */
3180 PL_last_proto = SvPV((SV*)cv, len);
3183 if (strEQ(PL_last_proto, "$"))
3185 if (*PL_last_proto == '&' && *s == '{') {
3186 sv_setpv(PL_subname,"__ANON__");
3190 PL_last_proto = NULL;
3191 PL_nextval[PL_nexttoke].opval = yylval.opval;
3197 if (PL_hints & HINT_STRICT_SUBS &&
3200 PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
3201 PL_last_lop_op != OP_ACCEPT &&
3202 PL_last_lop_op != OP_PIPE_OP &&
3203 PL_last_lop_op != OP_SOCKPAIR)
3206 "Bareword \"%s\" not allowed while \"strict subs\" in use",
3211 /* Call it a bare word */
3214 if (ckWARN(WARN_RESERVED)) {
3215 if (lastchar != '-') {
3216 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3218 warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
3223 if (lastchar && strchr("*%&", lastchar)) {
3224 warn("Operator or semicolon missing before %c%s",
3225 lastchar, PL_tokenbuf);
3226 warn("Ambiguous use of %c resolved as operator %c",
3227 lastchar, lastchar);
3233 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3234 newSVsv(GvSV(PL_curcop->cop_filegv)));
3238 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3239 newSVpvf("%ld", (long)PL_curcop->cop_line));
3242 case KEY___PACKAGE__:
3243 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3245 ? newSVsv(PL_curstname)
3254 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3255 char *pname = "main";
3256 if (PL_tokenbuf[2] == 'D')
3257 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3258 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3261 GvIOp(gv) = newIO();
3262 IoIFP(GvIOp(gv)) = PL_rsfp;
3263 #if defined(HAS_FCNTL) && defined(F_SETFD)
3265 int fd = PerlIO_fileno(PL_rsfp);
3266 fcntl(fd,F_SETFD,fd >= 3);
3269 /* Mark this internal pseudo-handle as clean */
3270 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3272 IoTYPE(GvIOp(gv)) = '|';
3273 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3274 IoTYPE(GvIOp(gv)) = '-';
3276 IoTYPE(GvIOp(gv)) = '<';
3287 if (PL_expect == XSTATE) {
3294 if (*s == ':' && s[1] == ':') {
3297 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3298 tmp = keyword(PL_tokenbuf, len);
3312 LOP(OP_ACCEPT,XTERM);
3318 LOP(OP_ATAN2,XTERM);
3327 LOP(OP_BLESS,XTERM);
3336 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
3353 if (!PL_cryptseen++)
3356 LOP(OP_CRYPT,XTERM);
3359 if (ckWARN(WARN_OCTAL)) {
3360 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3361 if (*d != '0' && isDIGIT(*d))
3362 yywarn("chmod: mode argument is missing initial 0");
3364 LOP(OP_CHMOD,XTERM);
3367 LOP(OP_CHOWN,XTERM);
3370 LOP(OP_CONNECT,XTERM);
3386 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3390 PL_hints |= HINT_BLOCK_SCOPE;
3400 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3401 LOP(OP_DBMOPEN,XTERM);
3407 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3414 yylval.ival = PL_curcop->cop_line;
3428 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3429 UNIBRACK(OP_ENTEREVAL);
3444 case KEY_endhostent:
3450 case KEY_endservent:
3453 case KEY_endprotoent:
3464 yylval.ival = PL_curcop->cop_line;
3466 if (PL_expect == XSTATE && isIDFIRST(*s)) {
3468 if ((PL_bufend - p) >= 3 &&
3469 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3473 croak("Missing $ on loop variable");
3478 LOP(OP_FORMLINE,XTERM);
3484 LOP(OP_FCNTL,XTERM);
3490 LOP(OP_FLOCK,XTERM);
3499 LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3502 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3517 case KEY_getpriority:
3518 LOP(OP_GETPRIORITY,XTERM);
3520 case KEY_getprotobyname:
3523 case KEY_getprotobynumber:
3524 LOP(OP_GPBYNUMBER,XTERM);
3526 case KEY_getprotoent:
3538 case KEY_getpeername:
3539 UNI(OP_GETPEERNAME);
3541 case KEY_gethostbyname:
3544 case KEY_gethostbyaddr:
3545 LOP(OP_GHBYADDR,XTERM);
3547 case KEY_gethostent:
3550 case KEY_getnetbyname:
3553 case KEY_getnetbyaddr:
3554 LOP(OP_GNBYADDR,XTERM);
3559 case KEY_getservbyname:
3560 LOP(OP_GSBYNAME,XTERM);
3562 case KEY_getservbyport:
3563 LOP(OP_GSBYPORT,XTERM);
3565 case KEY_getservent:
3568 case KEY_getsockname:
3569 UNI(OP_GETSOCKNAME);
3571 case KEY_getsockopt:
3572 LOP(OP_GSOCKOPT,XTERM);
3594 yylval.ival = PL_curcop->cop_line;
3598 LOP(OP_INDEX,XTERM);
3604 LOP(OP_IOCTL,XTERM);
3616 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3647 LOP(OP_LISTEN,XTERM);
3656 s = scan_pat(s,OP_MATCH);
3657 TERM(sublex_start());
3660 LOP(OP_MAPSTART,XREF);
3663 LOP(OP_MKDIR,XTERM);
3666 LOP(OP_MSGCTL,XTERM);
3669 LOP(OP_MSGGET,XTERM);
3672 LOP(OP_MSGRCV,XTERM);
3675 LOP(OP_MSGSND,XTERM);
3680 if (isIDFIRST(*s)) {
3681 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3682 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3683 if (!PL_in_my_stash) {
3686 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3693 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3700 if (PL_expect != XSTATE)
3701 yyerror("\"no\" not allowed in expression");
3702 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3703 s = force_version(s);
3712 if (isIDFIRST(*s)) {
3714 for (d = s; isALNUM(*d); d++) ;
3716 if (strchr("|&*+-=!?:.", *t))
3717 warn("Precedence problem: open %.*s should be open(%.*s)",
3723 yylval.ival = OP_OR;
3733 LOP(OP_OPEN_DIR,XTERM);
3736 checkcomma(s,PL_tokenbuf,"filehandle");
3740 checkcomma(s,PL_tokenbuf,"filehandle");
3759 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3763 LOP(OP_PIPE_OP,XTERM);
3768 missingterm((char*)0);
3769 yylval.ival = OP_CONST;
3770 TERM(sublex_start());
3778 missingterm((char*)0);
3779 if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3780 d = SvPV_force(PL_lex_stuff, len);
3781 for (; len; --len, ++d) {
3784 "Possible attempt to separate words with commas");
3789 "Possible attempt to put comments in qw() list");
3795 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3796 PL_lex_stuff = Nullsv;
3799 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3802 yylval.ival = OP_SPLIT;
3806 PL_last_lop = PL_oldbufptr;
3807 PL_last_lop_op = OP_SPLIT;
3813 missingterm((char*)0);
3814 yylval.ival = OP_STRINGIFY;
3815 if (SvIVX(PL_lex_stuff) == '\'')
3816 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
3817 TERM(sublex_start());
3820 s = scan_pat(s,OP_QR);
3821 TERM(sublex_start());
3826 missingterm((char*)0);
3827 yylval.ival = OP_BACKTICK;
3829 TERM(sublex_start());
3835 *PL_tokenbuf = '\0';
3836 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3837 if (isIDFIRST(*PL_tokenbuf))
3838 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3840 yyerror("<> should be quotes");
3847 s = force_word(s,WORD,TRUE,FALSE,FALSE);
3851 LOP(OP_RENAME,XTERM);
3860 LOP(OP_RINDEX,XTERM);
3883 LOP(OP_REVERSE,XTERM);
3894 TERM(sublex_start());
3896 TOKEN(1); /* force error */
3905 LOP(OP_SELECT,XTERM);
3911 LOP(OP_SEMCTL,XTERM);
3914 LOP(OP_SEMGET,XTERM);
3917 LOP(OP_SEMOP,XTERM);
3923 LOP(OP_SETPGRP,XTERM);
3925 case KEY_setpriority:
3926 LOP(OP_SETPRIORITY,XTERM);
3928 case KEY_sethostent:
3934 case KEY_setservent:
3937 case KEY_setprotoent:
3947 LOP(OP_SEEKDIR,XTERM);
3949 case KEY_setsockopt:
3950 LOP(OP_SSOCKOPT,XTERM);
3956 LOP(OP_SHMCTL,XTERM);
3959 LOP(OP_SHMGET,XTERM);
3962 LOP(OP_SHMREAD,XTERM);
3965 LOP(OP_SHMWRITE,XTERM);
3968 LOP(OP_SHUTDOWN,XTERM);
3977 LOP(OP_SOCKET,XTERM);
3979 case KEY_socketpair:
3980 LOP(OP_SOCKPAIR,XTERM);
3983 checkcomma(s,PL_tokenbuf,"subroutine name");
3985 if (*s == ';' || *s == ')') /* probably a close */
3986 croak("sort is now a reserved word");
3988 s = force_word(s,WORD,TRUE,TRUE,FALSE);
3992 LOP(OP_SPLIT,XTERM);
3995 LOP(OP_SPRINTF,XTERM);
3998 LOP(OP_SPLICE,XTERM);
4014 LOP(OP_SUBSTR,XTERM);
4021 if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
4022 char tmpbuf[sizeof PL_tokenbuf];
4024 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4025 if (strchr(tmpbuf, ':'))
4026 sv_setpv(PL_subname, tmpbuf);
4028 sv_setsv(PL_subname,PL_curstname);
4029 sv_catpvn(PL_subname,"::",2);
4030 sv_catpvn(PL_subname,tmpbuf,len);
4032 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4036 PL_expect = XTERMBLOCK;
4037 sv_setpv(PL_subname,"?");
4040 if (tmp == KEY_format) {
4043 PL_lex_formbrack = PL_lex_brackets + 1;
4047 /* Look for a prototype */
4054 SvREFCNT_dec(PL_lex_stuff);
4055 PL_lex_stuff = Nullsv;
4056 croak("Prototype not terminated");
4059 d = SvPVX(PL_lex_stuff);
4061 for (p = d; *p; ++p) {
4066 SvCUR(PL_lex_stuff) = tmp;
4069 PL_nextval[1] = PL_nextval[0];
4070 PL_nexttype[1] = PL_nexttype[0];
4071 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4072 PL_nexttype[0] = THING;
4073 if (PL_nexttoke == 1) {
4074 PL_lex_defer = PL_lex_state;
4075 PL_lex_expect = PL_expect;
4076 PL_lex_state = LEX_KNOWNEXT;
4078 PL_lex_stuff = Nullsv;
4081 if (*SvPV(PL_subname,PL_na) == '?') {
4082 sv_setpv(PL_subname,"__ANON__");
4089 LOP(OP_SYSTEM,XREF);
4092 LOP(OP_SYMLINK,XTERM);
4095 LOP(OP_SYSCALL,XTERM);
4098 LOP(OP_SYSOPEN,XTERM);
4101 LOP(OP_SYSSEEK,XTERM);
4104 LOP(OP_SYSREAD,XTERM);
4107 LOP(OP_SYSWRITE,XTERM);
4111 TERM(sublex_start());
4132 LOP(OP_TRUNCATE,XTERM);
4144 yylval.ival = PL_curcop->cop_line;
4148 yylval.ival = PL_curcop->cop_line;
4152 LOP(OP_UNLINK,XTERM);
4158 LOP(OP_UNPACK,XTERM);
4161 LOP(OP_UTIME,XTERM);
4164 if (ckWARN(WARN_OCTAL)) {
4165 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4166 if (*d != '0' && isDIGIT(*d))
4167 yywarn("umask: argument is missing initial 0");
4172 LOP(OP_UNSHIFT,XTERM);
4175 if (PL_expect != XSTATE)
4176 yyerror("\"use\" not allowed in expression");
4179 s = force_version(s);
4180 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4181 PL_nextval[PL_nexttoke].opval = Nullop;
4186 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4187 s = force_version(s);
4200 yylval.ival = PL_curcop->cop_line;
4204 PL_hints |= HINT_BLOCK_SCOPE;
4211 LOP(OP_WAITPID,XTERM);
4219 static char ctl_l[2];
4221 if (ctl_l[0] == '\0')
4222 ctl_l[0] = toCTRL('L');
4223 gv_fetchpv(ctl_l,TRUE, SVt_PV);
4226 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
4231 if (PL_expect == XOPERATOR)
4237 yylval.ival = OP_XOR;
4242 TERM(sublex_start());
4248 keyword(register char *d, I32 len)
4253 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
4254 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
4255 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
4256 if (strEQ(d,"__DATA__")) return KEY___DATA__;
4257 if (strEQ(d,"__END__")) return KEY___END__;
4261 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
4266 if (strEQ(d,"and")) return -KEY_and;
4267 if (strEQ(d,"abs")) return -KEY_abs;
4270 if (strEQ(d,"alarm")) return -KEY_alarm;
4271 if (strEQ(d,"atan2")) return -KEY_atan2;
4274 if (strEQ(d,"accept")) return -KEY_accept;
4279 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
4282 if (strEQ(d,"bless")) return -KEY_bless;
4283 if (strEQ(d,"bind")) return -KEY_bind;
4284 if (strEQ(d,"binmode")) return -KEY_binmode;
4287 if (strEQ(d,"CORE")) return -KEY_CORE;
4292 if (strEQ(d,"cmp")) return -KEY_cmp;
4293 if (strEQ(d,"chr")) return -KEY_chr;
4294 if (strEQ(d,"cos")) return -KEY_cos;
4297 if (strEQ(d,"chop")) return KEY_chop;
4300 if (strEQ(d,"close")) return -KEY_close;
4301 if (strEQ(d,"chdir")) return -KEY_chdir;
4302 if (strEQ(d,"chomp")) return KEY_chomp;
4303 if (strEQ(d,"chmod")) return -KEY_chmod;
4304 if (strEQ(d,"chown")) return -KEY_chown;
4305 if (strEQ(d,"crypt")) return -KEY_crypt;
4308 if (strEQ(d,"chroot")) return -KEY_chroot;
4309 if (strEQ(d,"caller")) return -KEY_caller;
4312 if (strEQ(d,"connect")) return -KEY_connect;
4315 if (strEQ(d,"closedir")) return -KEY_closedir;
4316 if (strEQ(d,"continue")) return -KEY_continue;
4321 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
4326 if (strEQ(d,"do")) return KEY_do;
4329 if (strEQ(d,"die")) return -KEY_die;
4332 if (strEQ(d,"dump")) return -KEY_dump;
4335 if (strEQ(d,"delete")) return KEY_delete;
4338 if (strEQ(d,"defined")) return KEY_defined;
4339 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
4342 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
4347 if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
4348 if (strEQ(d,"END")) return KEY_END;
4353 if (strEQ(d,"eq")) return -KEY_eq;
4356 if (strEQ(d,"eof")) return -KEY_eof;
4357 if (strEQ(d,"exp")) return -KEY_exp;
4360 if (strEQ(d,"else")) return KEY_else;
4361 if (strEQ(d,"exit")) return -KEY_exit;
4362 if (strEQ(d,"eval")) return KEY_eval;
4363 if (strEQ(d,"exec")) return -KEY_exec;
4364 if (strEQ(d,"each")) return KEY_each;
4367 if (strEQ(d,"elsif")) return KEY_elsif;
4370 if (strEQ(d,"exists")) return KEY_exists;
4371 if (strEQ(d,"elseif")) warn("elseif should be elsif");
4374 if (strEQ(d,"endgrent")) return -KEY_endgrent;
4375 if (strEQ(d,"endpwent")) return -KEY_endpwent;
4378 if (strEQ(d,"endnetent")) return -KEY_endnetent;
4381 if (strEQ(d,"endhostent")) return -KEY_endhostent;
4382 if (strEQ(d,"endservent")) return -KEY_endservent;
4385 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
4392 if (strEQ(d,"for")) return KEY_for;
4395 if (strEQ(d,"fork")) return -KEY_fork;
4398 if (strEQ(d,"fcntl")) return -KEY_fcntl;
4399 if (strEQ(d,"flock")) return -KEY_flock;
4402 if (strEQ(d,"format")) return KEY_format;
4403 if (strEQ(d,"fileno")) return -KEY_fileno;
4406 if (strEQ(d,"foreach")) return KEY_foreach;
4409 if (strEQ(d,"formline")) return -KEY_formline;
4415 if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
4416 if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
4420 if (strnEQ(d,"get",3)) {
4425 if (strEQ(d,"ppid")) return -KEY_getppid;
4426 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
4429 if (strEQ(d,"pwent")) return -KEY_getpwent;
4430 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
4431 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
4434 if (strEQ(d,"peername")) return -KEY_getpeername;
4435 if (strEQ(d,"protoent")) return -KEY_getprotoent;
4436 if (strEQ(d,"priority")) return -KEY_getpriority;
4439 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4442 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4446 else if (*d == 'h') {
4447 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
4448 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
4449 if (strEQ(d,"hostent")) return -KEY_gethostent;
4451 else if (*d == 'n') {
4452 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
4453 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
4454 if (strEQ(d,"netent")) return -KEY_getnetent;
4456 else if (*d == 's') {
4457 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
4458 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
4459 if (strEQ(d,"servent")) return -KEY_getservent;
4460 if (strEQ(d,"sockname")) return -KEY_getsockname;
4461 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
4463 else if (*d == 'g') {
4464 if (strEQ(d,"grent")) return -KEY_getgrent;
4465 if (strEQ(d,"grnam")) return -KEY_getgrnam;
4466 if (strEQ(d,"grgid")) return -KEY_getgrgid;
4468 else if (*d == 'l') {
4469 if (strEQ(d,"login")) return -KEY_getlogin;
4471 else if (strEQ(d,"c")) return -KEY_getc;
4476 if (strEQ(d,"gt")) return -KEY_gt;
4477 if (strEQ(d,"ge")) return -KEY_ge;
4480 if (strEQ(d,"grep")) return KEY_grep;
4481 if (strEQ(d,"goto")) return KEY_goto;
4482 if (strEQ(d,"glob")) return KEY_glob;
4485 if (strEQ(d,"gmtime")) return -KEY_gmtime;
4490 if (strEQ(d,"hex")) return -KEY_hex;
4493 if (strEQ(d,"INIT")) return KEY_INIT;
4498 if (strEQ(d,"if")) return KEY_if;
4501 if (strEQ(d,"int")) return -KEY_int;
4504 if (strEQ(d,"index")) return -KEY_index;
4505 if (strEQ(d,"ioctl")) return -KEY_ioctl;
4510 if (strEQ(d,"join")) return -KEY_join;
4514 if (strEQ(d,"keys")) return KEY_keys;
4515 if (strEQ(d,"kill")) return -KEY_kill;
4520 if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
4521 if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
4527 if (strEQ(d,"lt")) return -KEY_lt;
4528 if (strEQ(d,"le")) return -KEY_le;
4529 if (strEQ(d,"lc")) return -KEY_lc;
4532 if (strEQ(d,"log")) return -KEY_log;
4535 if (strEQ(d,"last")) return KEY_last;
4536 if (strEQ(d,"link")) return -KEY_link;
4537 if (strEQ(d,"lock")) return -KEY_lock;
4540 if (strEQ(d,"local")) return KEY_local;
4541 if (strEQ(d,"lstat")) return -KEY_lstat;
4544 if (strEQ(d,"length")) return -KEY_length;
4545 if (strEQ(d,"listen")) return -KEY_listen;
4548 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
4551 if (strEQ(d,"localtime")) return -KEY_localtime;
4557 case 1: return KEY_m;
4559 if (strEQ(d,"my")) return KEY_my;
4562 if (strEQ(d,"map")) return KEY_map;
4565 if (strEQ(d,"mkdir")) return -KEY_mkdir;
4568 if (strEQ(d,"msgctl")) return -KEY_msgctl;
4569 if (strEQ(d,"msgget")) return -KEY_msgget;
4570 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
4571 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
4576 if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
4579 if (strEQ(d,"next")) return KEY_next;
4580 if (strEQ(d,"ne")) return -KEY_ne;
4581 if (strEQ(d,"not")) return -KEY_not;
4582 if (strEQ(d,"no")) return KEY_no;
4587 if (strEQ(d,"or")) return -KEY_or;
4590 if (strEQ(d,"ord")) return -KEY_ord;
4591 if (strEQ(d,"oct")) return -KEY_oct;
4592 if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4596 if (strEQ(d,"open")) return -KEY_open;
4599 if (strEQ(d,"opendir")) return -KEY_opendir;
4606 if (strEQ(d,"pop")) return KEY_pop;
4607 if (strEQ(d,"pos")) return KEY_pos;
4610 if (strEQ(d,"push")) return KEY_push;
4611 if (strEQ(d,"pack")) return -KEY_pack;
4612 if (strEQ(d,"pipe")) return -KEY_pipe;
4615 if (strEQ(d,"print")) return KEY_print;
4618 if (strEQ(d,"printf")) return KEY_printf;
4621 if (strEQ(d,"package")) return KEY_package;
4624 if (strEQ(d,"prototype")) return KEY_prototype;
4629 if (strEQ(d,"q")) return KEY_q;
4630 if (strEQ(d,"qr")) return KEY_qr;
4631 if (strEQ(d,"qq")) return KEY_qq;
4632 if (strEQ(d,"qw")) return KEY_qw;
4633 if (strEQ(d,"qx")) return KEY_qx;
4635 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
4640 if (strEQ(d,"ref")) return -KEY_ref;
4643 if (strEQ(d,"read")) return -KEY_read;
4644 if (strEQ(d,"rand")) return -KEY_rand;
4645 if (strEQ(d,"recv")) return -KEY_recv;
4646 if (strEQ(d,"redo")) return KEY_redo;
4649 if (strEQ(d,"rmdir")) return -KEY_rmdir;
4650 if (strEQ(d,"reset")) return -KEY_reset;
4653 if (strEQ(d,"return")) return KEY_return;
4654 if (strEQ(d,"rename")) return -KEY_rename;
4655 if (strEQ(d,"rindex")) return -KEY_rindex;
4658 if (strEQ(d,"require")) return -KEY_require;
4659 if (strEQ(d,"reverse")) return -KEY_reverse;
4660 if (strEQ(d,"readdir")) return -KEY_readdir;
4663 if (strEQ(d,"readlink")) return -KEY_readlink;
4664 if (strEQ(d,"readline")) return -KEY_readline;
4665 if (strEQ(d,"readpipe")) return -KEY_readpipe;
4668 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
4674 case 0: return KEY_s;
4676 if (strEQ(d,"scalar")) return KEY_scalar;
4681 if (strEQ(d,"seek")) return -KEY_seek;
4682 if (strEQ(d,"send")) return -KEY_send;
4685 if (strEQ(d,"semop")) return -KEY_semop;
4688 if (strEQ(d,"select")) return -KEY_select;
4689 if (strEQ(d,"semctl")) return -KEY_semctl;
4690 if (strEQ(d,"semget")) return -KEY_semget;
4693 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
4694 if (strEQ(d,"seekdir")) return -KEY_seekdir;
4697 if (strEQ(d,"setpwent")) return -KEY_setpwent;
4698 if (strEQ(d,"setgrent")) return -KEY_setgrent;
4701 if (strEQ(d,"setnetent")) return -KEY_setnetent;
4704 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
4705 if (strEQ(d,"sethostent")) return -KEY_sethostent;
4706 if (strEQ(d,"setservent")) return -KEY_setservent;
4709 if (strEQ(d,"setpriority")) return -KEY_setpriority;
4710 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
4717 if (strEQ(d,"shift")) return KEY_shift;
4720 if (strEQ(d,"shmctl")) return -KEY_shmctl;
4721 if (strEQ(d,"shmget")) return -KEY_shmget;
4724 if (strEQ(d,"shmread")) return -KEY_shmread;
4727 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
4728 if (strEQ(d,"shutdown")) return -KEY_shutdown;
4733 if (strEQ(d,"sin")) return -KEY_sin;
4736 if (strEQ(d,"sleep")) return -KEY_sleep;
4739 if (strEQ(d,"sort")) return KEY_sort;
4740 if (strEQ(d,"socket")) return -KEY_socket;
4741 if (strEQ(d,"socketpair")) return -KEY_socketpair;
4744 if (strEQ(d,"split")) return KEY_split;
4745 if (strEQ(d,"sprintf")) return -KEY_sprintf;
4746 if (strEQ(d,"splice")) return KEY_splice;
4749 if (strEQ(d,"sqrt")) return -KEY_sqrt;
4752 if (strEQ(d,"srand")) return -KEY_srand;
4755 if (strEQ(d,"stat")) return -KEY_stat;
4756 if (strEQ(d,"study")) return KEY_study;
4759 if (strEQ(d,"substr")) return -KEY_substr;
4760 if (strEQ(d,"sub")) return KEY_sub;
4765 if (strEQ(d,"system")) return -KEY_system;
4768 if (strEQ(d,"symlink")) return -KEY_symlink;
4769 if (strEQ(d,"syscall")) return -KEY_syscall;
4770 if (strEQ(d,"sysopen")) return -KEY_sysopen;
4771 if (strEQ(d,"sysread")) return -KEY_sysread;
4772 if (strEQ(d,"sysseek")) return -KEY_sysseek;
4775 if (strEQ(d,"syswrite")) return -KEY_syswrite;
4784 if (strEQ(d,"tr")) return KEY_tr;
4787 if (strEQ(d,"tie")) return KEY_tie;
4790 if (strEQ(d,"tell")) return -KEY_tell;
4791 if (strEQ(d,"tied")) return KEY_tied;
4792 if (strEQ(d,"time")) return -KEY_time;
4795 if (strEQ(d,"times")) return -KEY_times;
4798 if (strEQ(d,"telldir")) return -KEY_telldir;
4801 if (strEQ(d,"truncate")) return -KEY_truncate;
4808 if (strEQ(d,"uc")) return -KEY_uc;
4811 if (strEQ(d,"use")) return KEY_use;
4814 if (strEQ(d,"undef")) return KEY_undef;
4815 if (strEQ(d,"until")) return KEY_until;
4816 if (strEQ(d,"untie")) return KEY_untie;
4817 if (strEQ(d,"utime")) return -KEY_utime;
4818 if (strEQ(d,"umask")) return -KEY_umask;
4821 if (strEQ(d,"unless")) return KEY_unless;
4822 if (strEQ(d,"unpack")) return -KEY_unpack;
4823 if (strEQ(d,"unlink")) return -KEY_unlink;
4826 if (strEQ(d,"unshift")) return KEY_unshift;
4827 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
4832 if (strEQ(d,"values")) return -KEY_values;
4833 if (strEQ(d,"vec")) return -KEY_vec;
4838 if (strEQ(d,"warn")) return -KEY_warn;
4839 if (strEQ(d,"wait")) return -KEY_wait;
4842 if (strEQ(d,"while")) return KEY_while;
4843 if (strEQ(d,"write")) return -KEY_write;
4846 if (strEQ(d,"waitpid")) return -KEY_waitpid;
4849 if (strEQ(d,"wantarray")) return -KEY_wantarray;
4854 if (len == 1) return -KEY_x;
4855 if (strEQ(d,"xor")) return -KEY_xor;
4858 if (len == 1) return KEY_y;
4867 checkcomma(register char *s, char *name, char *what)
4871 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
4872 dTHR; /* only for ckWARN */
4873 if (ckWARN(WARN_SYNTAX)) {
4875 for (w = s+2; *w && level; w++) {
4882 for (; *w && isSPACE(*w); w++) ;
4883 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4884 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4887 while (s < PL_bufend && isSPACE(*s))
4891 while (s < PL_bufend && isSPACE(*s))
4893 if (isIDFIRST(*s)) {
4897 while (s < PL_bufend && isSPACE(*s))
4902 kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4906 croak("No comma allowed after %s", what);
4912 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4915 HV *table = GvHV(PL_hintgv); /* ^H */
4918 bool oldcatch = CATCH_GET;
4924 yyerror("%^H is not defined");
4927 cvp = hv_fetch(table, key, strlen(key), FALSE);
4928 if (!cvp || !SvOK(*cvp)) {
4929 sprintf(buf,"$^H{%s} is not defined", key);
4933 sv_2mortal(sv); /* Parent created it permanently */
4936 pv = sv_2mortal(newSVpv(s, len));
4938 typesv = sv_2mortal(newSVpv(type, 0));
4940 typesv = &PL_sv_undef;
4942 Zero(&myop, 1, BINOP);
4943 myop.op_last = (OP *) &myop;
4944 myop.op_next = Nullop;
4945 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4947 PUSHSTACKi(PERLSI_OVERLOAD);
4950 PL_op = (OP *) &myop;
4951 if (PERLDB_SUB && PL_curstash != PL_debstash)
4952 PL_op->op_private |= OPpENTERSUB_DB;
4963 if (PL_op = pp_entersub(ARGS))
4970 CATCH_SET(oldcatch);
4974 sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4977 return SvREFCNT_inc(res);
4981 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4983 register char *d = dest;
4984 register char *e = d + destlen - 3; /* two-character token, ending NUL */
4987 croak(ident_too_long);
4990 else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4995 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4999 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
5000 char *t = s + UTF8SKIP(s);
5001 while (*t & 0x80 && is_utf8_mark((U8*)t))
5003 if (d + (t - s) > e)
5004 croak(ident_too_long);
5005 Copy(s, d, t - s, char);
5018 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5025 if (PL_lex_brackets == 0)
5026 PL_lex_fakebrack = 0;
5030 e = d + destlen - 3; /* two-character token, ending NUL */
5032 while (isDIGIT(*s)) {
5034 croak(ident_too_long);
5041 croak(ident_too_long);
5044 else if (*s == '\'' && isIDFIRST(s[1])) {
5049 else if (*s == ':' && s[1] == ':') {
5053 else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8((U8*)s)) {
5054 char *t = s + UTF8SKIP(s);
5055 while (*t & 0x80 && is_utf8_mark((U8*)t))
5057 if (d + (t - s) > e)
5058 croak(ident_too_long);
5059 Copy(s, d, t - s, char);
5070 if (PL_lex_state != LEX_NORMAL)
5071 PL_lex_state = LEX_INTERPENDMAYBE;
5074 if (*s == '$' && s[1] &&
5075 (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5077 if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
5078 deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
5091 if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5096 if (isSPACE(s[-1])) {
5099 if (ch != ' ' && ch != '\t') {
5105 if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8((U8*)d))) {
5109 while (e < send && (isALNUM(*e) || ((*e & 0xc0) == 0x80 && isALNUM_utf8((U8*)e)) || *e == ':')) {
5111 while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5114 Copy(s, d, e - s, char);
5119 while (isALNUM(*s) || *s == ':')
5123 while (s < send && (*s == ' ' || *s == '\t')) s++;
5124 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5125 dTHR; /* only for ckWARN */
5126 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5127 char *brack = *s == '[' ? "[...]" : "{...}";
5128 warner(WARN_AMBIGUOUS,
5129 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5130 funny, dest, brack, funny, dest, brack);
5132 PL_lex_fakebrack = PL_lex_brackets+1;
5134 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5140 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5141 PL_lex_state = LEX_INTERPEND;
5144 if (PL_lex_state == LEX_NORMAL) {
5145 dTHR; /* only for ckWARN */
5146 if (ckWARN(WARN_AMBIGUOUS) &&
5147 (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5149 warner(WARN_AMBIGUOUS,
5150 "Ambiguous use of %c{%s} resolved to %c%s",
5151 funny, dest, funny, dest);
5156 s = bracket; /* let the parser handle it */
5160 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5161 PL_lex_state = LEX_INTERPEND;
5165 void pmflag(U16 *pmfl, int ch)
5170 *pmfl |= PMf_GLOBAL;
5172 *pmfl |= PMf_CONTINUE;
5176 *pmfl |= PMf_MULTILINE;
5178 *pmfl |= PMf_SINGLELINE;
5180 *pmfl |= PMf_EXTENDED;
5184 scan_pat(char *start, I32 type)
5189 s = scan_str(start);
5192 SvREFCNT_dec(PL_lex_stuff);
5193 PL_lex_stuff = Nullsv;
5194 croak("Search pattern not terminated");
5197 pm = (PMOP*)newPMOP(type, 0);
5198 if (PL_multi_open == '?')
5199 pm->op_pmflags |= PMf_ONCE;
5201 while (*s && strchr("iomsx", *s))
5202 pmflag(&pm->op_pmflags,*s++);
5205 while (*s && strchr("iogcmsx", *s))
5206 pmflag(&pm->op_pmflags,*s++);
5208 pm->op_pmpermflags = pm->op_pmflags;
5210 PL_lex_op = (OP*)pm;
5211 yylval.ival = OP_MATCH;
5216 scan_subst(char *start)
5223 yylval.ival = OP_NULL;
5225 s = scan_str(start);
5229 SvREFCNT_dec(PL_lex_stuff);
5230 PL_lex_stuff = Nullsv;
5231 croak("Substitution pattern not terminated");
5234 if (s[-1] == PL_multi_open)
5237 first_start = PL_multi_start;
5241 SvREFCNT_dec(PL_lex_stuff);
5242 PL_lex_stuff = Nullsv;
5244 SvREFCNT_dec(PL_lex_repl);
5245 PL_lex_repl = Nullsv;
5246 croak("Substitution replacement not terminated");
5248 PL_multi_start = first_start; /* so whole substitution is taken together */
5250 pm = (PMOP*)newPMOP(OP_SUBST, 0);
5256 else if (strchr("iogcmsx", *s))
5257 pmflag(&pm->op_pmflags,*s++);
5264 pm->op_pmflags |= PMf_EVAL;
5265 repl = newSVpv("",0);
5267 sv_catpv(repl, es ? "eval " : "do ");
5268 sv_catpvn(repl, "{ ", 2);
5269 sv_catsv(repl, PL_lex_repl);
5270 sv_catpvn(repl, " };", 2);
5271 SvCOMPILED_on(repl);
5272 SvREFCNT_dec(PL_lex_repl);
5276 pm->op_pmpermflags = pm->op_pmflags;
5277 PL_lex_op = (OP*)pm;
5278 yylval.ival = OP_SUBST;
5283 scan_trans(char *start)
5294 yylval.ival = OP_NULL;
5296 s = scan_str(start);
5299 SvREFCNT_dec(PL_lex_stuff);
5300 PL_lex_stuff = Nullsv;
5301 croak("Transliteration pattern not terminated");
5303 if (s[-1] == PL_multi_open)
5309 SvREFCNT_dec(PL_lex_stuff);
5310 PL_lex_stuff = Nullsv;
5312 SvREFCNT_dec(PL_lex_repl);
5313 PL_lex_repl = Nullsv;
5314 croak("Transliteration replacement not terminated");
5318 o = newSVOP(OP_TRANS, 0, 0);
5319 utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5322 New(803,tbl,256,short);
5323 o = newPVOP(OP_TRANS, 0, (char*)tbl);
5327 complement = del = squash = 0;
5328 while (strchr("cdsCU", *s)) {
5330 complement = OPpTRANS_COMPLEMENT;
5332 del = OPpTRANS_DELETE;
5334 squash = OPpTRANS_SQUASH;
5339 utf8 &= ~OPpTRANS_FROM_UTF;
5341 utf8 |= OPpTRANS_FROM_UTF;
5345 utf8 &= ~OPpTRANS_TO_UTF;
5347 utf8 |= OPpTRANS_TO_UTF;
5350 croak("Too many /C and /U options");
5355 o->op_private = del|squash|complement|utf8;
5358 yylval.ival = OP_TRANS;
5363 scan_heredoc(register char *s)
5367 I32 op_type = OP_SCALAR;
5374 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5378 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5381 for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5382 if (*peek && strchr("`'\"",*peek)) {
5385 s = delimcpy(d, e, s, PL_bufend, term, &len);
5396 deprecate("bare << to mean <<\"\"");
5397 for (; isALNUM(*s); s++) {
5402 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5403 croak("Delimiter for here document is too long");
5406 len = d - PL_tokenbuf;
5407 #ifndef PERL_STRICT_CR
5408 d = strchr(s, '\r');
5412 while (s < PL_bufend) {
5418 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
5427 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5432 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5433 herewas = newSVpv(s,PL_bufend-s);
5435 s--, herewas = newSVpv(s,d-s);
5436 s += SvCUR(herewas);
5438 tmpstr = NEWSV(87,79);
5439 sv_upgrade(tmpstr, SVt_PVIV);
5444 else if (term == '`') {
5445 op_type = OP_BACKTICK;
5446 SvIVX(tmpstr) = '\\';
5450 PL_multi_start = PL_curcop->cop_line;
5451 PL_multi_open = PL_multi_close = '<';
5452 term = *PL_tokenbuf;
5455 while (s < PL_bufend &&
5456 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5458 PL_curcop->cop_line++;
5460 if (s >= PL_bufend) {
5461 PL_curcop->cop_line = PL_multi_start;
5462 missingterm(PL_tokenbuf);
5464 sv_setpvn(tmpstr,d+1,s-d);
5466 PL_curcop->cop_line++; /* the preceding stmt passes a newline */
5468 sv_catpvn(herewas,s,PL_bufend-s);
5469 sv_setsv(PL_linestr,herewas);
5470 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5471 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5474 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
5475 while (s >= PL_bufend) { /* multiple line string? */
5477 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5478 PL_curcop->cop_line = PL_multi_start;
5479 missingterm(PL_tokenbuf);
5481 PL_curcop->cop_line++;
5482 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5483 #ifndef PERL_STRICT_CR
5484 if (PL_bufend - PL_linestart >= 2) {
5485 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5486 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5488 PL_bufend[-2] = '\n';
5490 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5492 else if (PL_bufend[-1] == '\r')
5493 PL_bufend[-1] = '\n';
5495 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5496 PL_bufend[-1] = '\n';
5498 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5499 SV *sv = NEWSV(88,0);
5501 sv_upgrade(sv, SVt_PVMG);
5502 sv_setsv(sv,PL_linestr);
5503 av_store(GvAV(PL_curcop->cop_filegv),
5504 (I32)PL_curcop->cop_line,sv);
5506 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5509 sv_catsv(PL_linestr,herewas);
5510 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5514 sv_catsv(tmpstr,PL_linestr);
5517 PL_multi_end = PL_curcop->cop_line;
5519 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5520 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5521 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5523 SvREFCNT_dec(herewas);
5524 PL_lex_stuff = tmpstr;
5525 yylval.ival = op_type;
5530 takes: current position in input buffer
5531 returns: new position in input buffer
5532 side-effects: yylval and lex_op are set.
5537 <FH> read from filehandle
5538 <pkg::FH> read from package qualified filehandle
5539 <pkg'FH> read from package qualified filehandle
5540 <$fh> read from filehandle in $fh
5546 scan_inputsymbol(char *start)
5548 register char *s = start; /* current position in buffer */
5553 d = PL_tokenbuf; /* start of temp holding space */
5554 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
5555 s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
5557 /* die if we didn't have space for the contents of the <>,
5561 if (len >= sizeof PL_tokenbuf)
5562 croak("Excessively long <> operator");
5564 croak("Unterminated <> operator");
5569 Remember, only scalar variables are interpreted as filehandles by
5570 this code. Anything more complex (e.g., <$fh{$num}>) will be
5571 treated as a glob() call.
5572 This code makes use of the fact that except for the $ at the front,
5573 a scalar variable and a filehandle look the same.
5575 if (*d == '$' && d[1]) d++;
5577 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5578 while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5581 /* If we've tried to read what we allow filehandles to look like, and
5582 there's still text left, then it must be a glob() and not a getline.
5583 Use scan_str to pull out the stuff between the <> and treat it
5584 as nothing more than a string.
5587 if (d - PL_tokenbuf != len) {
5588 yylval.ival = OP_GLOB;
5590 s = scan_str(start);
5592 croak("Glob not terminated");
5596 /* we're in a filehandle read situation */
5599 /* turn <> into <ARGV> */
5601 (void)strcpy(d,"ARGV");
5603 /* if <$fh>, create the ops to turn the variable into a
5609 /* try to find it in the pad for this block, otherwise find
5610 add symbol table ops
5612 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5613 OP *o = newOP(OP_PADSV, 0);
5615 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5618 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5619 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5620 newUNOP(OP_RV2GV, 0,
5621 newUNOP(OP_RV2SV, 0,
5622 newGVOP(OP_GV, 0, gv))));
5624 /* we created the ops in lex_op, so make yylval.ival a null op */
5625 yylval.ival = OP_NULL;
5628 /* If it's none of the above, it must be a literal filehandle
5629 (<Foo::BAR> or <FOO>) so build a simple readline OP */
5631 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5632 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5633 yylval.ival = OP_NULL;
5642 takes: start position in buffer
5643 returns: position to continue reading from buffer
5644 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5645 updates the read buffer.
5647 This subroutine pulls a string out of the input. It is called for:
5648 q single quotes q(literal text)
5649 ' single quotes 'literal text'
5650 qq double quotes qq(interpolate $here please)
5651 " double quotes "interpolate $here please"
5652 qx backticks qx(/bin/ls -l)
5653 ` backticks `/bin/ls -l`
5654 qw quote words @EXPORT_OK = qw( func() $spam )
5655 m// regexp match m/this/
5656 s/// regexp substitute s/this/that/
5657 tr/// string transliterate tr/this/that/
5658 y/// string transliterate y/this/that/
5659 ($*@) sub prototypes sub foo ($)
5660 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
5662 In most of these cases (all but <>, patterns and transliterate)
5663 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
5664 calls scan_str(). s/// makes yylex() call scan_subst() which calls
5665 scan_str(). tr/// and y/// make yylex() call scan_trans() which
5668 It skips whitespace before the string starts, and treats the first
5669 character as the delimiter. If the delimiter is one of ([{< then
5670 the corresponding "close" character )]}> is used as the closing
5671 delimiter. It allows quoting of delimiters, and if the string has
5672 balanced delimiters ([{<>}]) it allows nesting.
5674 The lexer always reads these strings into lex_stuff, except in the
5675 case of the operators which take *two* arguments (s/// and tr///)
5676 when it checks to see if lex_stuff is full (presumably with the 1st
5677 arg to s or tr) and if so puts the string into lex_repl.
5682 scan_str(char *start)
5685 SV *sv; /* scalar value: string */
5686 char *tmps; /* temp string, used for delimiter matching */
5687 register char *s = start; /* current position in the buffer */
5688 register char term; /* terminating character */
5689 register char *to; /* current position in the sv's data */
5690 I32 brackets = 1; /* bracket nesting level */
5692 /* skip space before the delimiter */
5696 /* mark where we are, in case we need to report errors */
5699 /* after skipping whitespace, the next character is the terminator */
5701 /* mark where we are */
5702 PL_multi_start = PL_curcop->cop_line;
5703 PL_multi_open = term;
5705 /* find corresponding closing delimiter */
5706 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5708 PL_multi_close = term;
5710 /* create a new SV to hold the contents. 87 is leak category, I'm
5711 assuming. 79 is the SV's initial length. What a random number. */
5713 sv_upgrade(sv, SVt_PVIV);
5715 (void)SvPOK_only(sv); /* validate pointer */
5717 /* move past delimiter and try to read a complete string */
5720 /* extend sv if need be */
5721 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5722 /* set 'to' to the next character in the sv's string */
5723 to = SvPVX(sv)+SvCUR(sv);
5725 /* if open delimiter is the close delimiter read unbridle */
5726 if (PL_multi_open == PL_multi_close) {
5727 for (; s < PL_bufend; s++,to++) {
5728 /* embedded newlines increment the current line number */
5729 if (*s == '\n' && !PL_rsfp)
5730 PL_curcop->cop_line++;
5731 /* handle quoted delimiters */
5732 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5735 /* any other quotes are simply copied straight through */
5739 /* terminate when run out of buffer (the for() condition), or
5740 have found the terminator */
5741 else if (*s == term)
5747 /* if the terminator isn't the same as the start character (e.g.,
5748 matched brackets), we have to allow more in the quoting, and
5749 be prepared for nested brackets.
5752 /* read until we run out of string, or we find the terminator */
5753 for (; s < PL_bufend; s++,to++) {
5754 /* embedded newlines increment the line count */
5755 if (*s == '\n' && !PL_rsfp)
5756 PL_curcop->cop_line++;
5757 /* backslashes can escape the open or closing characters */
5758 if (*s == '\\' && s+1 < PL_bufend) {
5759 if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5764 /* allow nested opens and closes */
5765 else if (*s == PL_multi_close && --brackets <= 0)
5767 else if (*s == PL_multi_open)
5772 /* terminate the copied string and update the sv's end-of-string */
5774 SvCUR_set(sv, to - SvPVX(sv));
5777 * this next chunk reads more into the buffer if we're not done yet
5780 if (s < PL_bufend) break; /* handle case where we are done yet :-) */
5782 #ifndef PERL_STRICT_CR
5783 if (to - SvPVX(sv) >= 2) {
5784 if ((to[-2] == '\r' && to[-1] == '\n') ||
5785 (to[-2] == '\n' && to[-1] == '\r'))
5789 SvCUR_set(sv, to - SvPVX(sv));
5791 else if (to[-1] == '\r')
5794 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5798 /* if we're out of file, or a read fails, bail and reset the current
5799 line marker so we can report where the unterminated string began
5802 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5804 PL_curcop->cop_line = PL_multi_start;
5807 /* we read a line, so increment our line counter */
5808 PL_curcop->cop_line++;
5810 /* update debugger info */
5811 if (PERLDB_LINE && PL_curstash != PL_debstash) {
5812 SV *sv = NEWSV(88,0);
5814 sv_upgrade(sv, SVt_PVMG);
5815 sv_setsv(sv,PL_linestr);
5816 av_store(GvAV(PL_curcop->cop_filegv),
5817 (I32)PL_curcop->cop_line, sv);
5820 /* having changed the buffer, we must update PL_bufend */
5821 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5824 /* at this point, we have successfully read the delimited string */
5826 PL_multi_end = PL_curcop->cop_line;
5829 /* if we allocated too much space, give some back */
5830 if (SvCUR(sv) + 5 < SvLEN(sv)) {
5831 SvLEN_set(sv, SvCUR(sv) + 1);
5832 Renew(SvPVX(sv), SvLEN(sv), char);
5835 /* decide whether this is the first or second quoted string we've read
5848 takes: pointer to position in buffer
5849 returns: pointer to new position in buffer
5850 side-effects: builds ops for the constant in yylval.op
5852 Read a number in any of the formats that Perl accepts:
5854 0(x[0-7A-F]+)|([0-7]+)
5855 [\d_]+(\.[\d_]*)?[Ee](\d+)
5857 Underbars (_) are allowed in decimal numbers. If -w is on,
5858 underbars before a decimal point must be at three digit intervals.
5860 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5863 If it reads a number without a decimal point or an exponent, it will
5864 try converting the number to an integer and see if it can do so
5865 without loss of precision.
5869 scan_num(char *start)
5871 register char *s = start; /* current position in buffer */
5872 register char *d; /* destination in temp buffer */
5873 register char *e; /* end of temp buffer */
5874 I32 tryiv; /* used to see if it can be an int */
5875 double value; /* number read, as a double */
5876 SV *sv; /* place to put the converted number */
5877 I32 floatit; /* boolean: int or float? */
5878 char *lastub = 0; /* position of last underbar */
5879 static char number_too_long[] = "Number too long";
5881 /* We use the first character to decide what type of number this is */
5885 croak("panic: scan_num");
5887 /* if it starts with a 0, it could be an octal number, a decimal in
5888 0.13 disguise, or a hexadecimal number.
5893 u holds the "number so far"
5894 shift the power of 2 of the base (hex == 4, octal == 3)
5895 overflowed was the number more than we can hold?
5897 Shift is used when we add a digit. It also serves as an "are
5898 we in octal or hex?" indicator to disallow hex characters when
5903 bool overflowed = FALSE;
5910 /* check for a decimal in disguise */
5911 else if (s[1] == '.')
5913 /* so it must be octal */
5918 /* read the rest of the octal number */
5920 UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
5924 /* if we don't mention it, we're done */
5933 /* 8 and 9 are not octal */
5936 yyerror("Illegal octal digit");
5940 case '0': case '1': case '2': case '3': case '4':
5941 case '5': case '6': case '7':
5942 b = *s++ & 15; /* ASCII digit -> value of digit */
5946 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5947 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5948 /* make sure they said 0x */
5953 /* Prepare to put the digit we have onto the end
5954 of the number so far. We check for overflows.
5958 n = u << shift; /* make room for the digit */
5959 if (!overflowed && (n >> shift) != u
5960 && !(PL_hints & HINT_NEW_BINARY)) {
5961 warn("Integer overflow in %s number",
5962 (shift == 4) ? "hex" : "octal");
5965 u = n | b; /* add the digit to the end */
5970 /* if we get here, we had success: make a scalar value from
5976 if ( PL_hints & HINT_NEW_BINARY)
5977 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5982 handle decimal numbers.
5983 we're also sent here when we read a 0 as the first digit
5985 case '1': case '2': case '3': case '4': case '5':
5986 case '6': case '7': case '8': case '9': case '.':
5989 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5992 /* read next group of digits and _ and copy into d */
5993 while (isDIGIT(*s) || *s == '_') {
5994 /* skip underscores, checking for misplaced ones
5998 dTHR; /* only for ckWARN */
5999 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6000 warner(WARN_SYNTAX, "Misplaced _ in number");
6004 /* check for end of fixed-length buffer */
6006 croak(number_too_long);
6007 /* if we're ok, copy the character */
6012 /* final misplaced underbar check */
6013 if (lastub && s - lastub != 3) {
6015 if (ckWARN(WARN_SYNTAX))
6016 warner(WARN_SYNTAX, "Misplaced _ in number");
6019 /* read a decimal portion if there is one. avoid
6020 3..5 being interpreted as the number 3. followed
6023 if (*s == '.' && s[1] != '.') {
6027 /* copy, ignoring underbars, until we run out of
6028 digits. Note: no misplaced underbar checks!
6030 for (; isDIGIT(*s) || *s == '_'; s++) {
6031 /* fixed length buffer check */
6033 croak(number_too_long);
6039 /* read exponent part, if present */
6040 if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6044 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6045 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
6047 /* allow positive or negative exponent */
6048 if (*s == '+' || *s == '-')
6051 /* read digits of exponent (no underbars :-) */
6052 while (isDIGIT(*s)) {
6054 croak(number_too_long);
6059 /* terminate the string */
6062 /* make an sv from the string */
6064 /* reset numeric locale in case we were earlier left in Swaziland */
6065 SET_NUMERIC_STANDARD();
6066 value = atof(PL_tokenbuf);
6069 See if we can make do with an integer value without loss of
6070 precision. We use I_V to cast to an int, because some
6071 compilers have issues. Then we try casting it back and see
6072 if it was the same. We only do this if we know we
6073 specifically read an integer.
6075 Note: if floatit is true, then we don't need to do the
6079 if (!floatit && (double)tryiv == value)
6080 sv_setiv(sv, tryiv);
6082 sv_setnv(sv, value);
6083 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6084 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6085 (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6089 /* make the op for the constant and return */
6091 yylval.opval = newSVOP(OP_CONST, 0, sv);
6097 scan_formline(register char *s)
6102 SV *stuff = newSVpv("",0);
6103 bool needargs = FALSE;
6106 if (*s == '.' || *s == '}') {
6108 #ifdef PERL_STRICT_CR
6109 for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6111 for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6116 if (PL_in_eval && !PL_rsfp) {
6117 eol = strchr(s,'\n');
6122 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6124 for (t = s; t < eol; t++) {
6125 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6127 goto enough; /* ~~ must be first line in formline */
6129 if (*t == '@' || *t == '^')
6132 sv_catpvn(stuff, s, eol-s);
6136 s = filter_gets(PL_linestr, PL_rsfp, 0);
6137 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6138 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6141 yyerror("Format not terminated");
6151 PL_lex_state = LEX_NORMAL;
6152 PL_nextval[PL_nexttoke].ival = 0;
6156 PL_lex_state = LEX_FORMLINE;
6157 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6159 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6163 SvREFCNT_dec(stuff);
6164 PL_lex_formbrack = 0;
6175 PL_cshlen = strlen(PL_cshname);
6180 start_subparse(I32 is_format, U32 flags)
6183 I32 oldsavestack_ix = PL_savestack_ix;
6184 CV* outsidecv = PL_compcv;
6188 assert(SvTYPE(PL_compcv) == SVt_PVCV);
6190 save_I32(&PL_subline);
6191 save_item(PL_subname);
6193 SAVESPTR(PL_curpad);
6194 SAVESPTR(PL_comppad);
6195 SAVESPTR(PL_comppad_name);
6196 SAVESPTR(PL_compcv);
6197 SAVEI32(PL_comppad_name_fill);
6198 SAVEI32(PL_min_intro_pending);
6199 SAVEI32(PL_max_intro_pending);
6200 SAVEI32(PL_pad_reset_pending);
6202 PL_compcv = (CV*)NEWSV(1104,0);
6203 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6204 CvFLAGS(PL_compcv) |= flags;
6206 PL_comppad = newAV();
6207 av_push(PL_comppad, Nullsv);
6208 PL_curpad = AvARRAY(PL_comppad);
6209 PL_comppad_name = newAV();
6210 PL_comppad_name_fill = 0;
6211 PL_min_intro_pending = 0;
6213 PL_subline = PL_curcop->cop_line;
6215 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6216 PL_curpad[0] = (SV*)newAV();
6217 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
6218 #endif /* USE_THREADS */
6220 comppadlist = newAV();
6221 AvREAL_off(comppadlist);
6222 av_store(comppadlist, 0, (SV*)PL_comppad_name);
6223 av_store(comppadlist, 1, (SV*)PL_comppad);
6225 CvPADLIST(PL_compcv) = comppadlist;
6226 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6228 CvOWNER(PL_compcv) = 0;
6229 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6230 MUTEX_INIT(CvMUTEXP(PL_compcv));
6231 #endif /* USE_THREADS */
6233 return oldsavestack_ix;
6252 char *context = NULL;
6256 if (!yychar || (yychar == ';' && !PL_rsfp))
6258 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6259 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6260 while (isSPACE(*PL_oldoldbufptr))
6262 context = PL_oldoldbufptr;
6263 contlen = PL_bufptr - PL_oldoldbufptr;
6265 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6266 PL_oldbufptr != PL_bufptr) {
6267 while (isSPACE(*PL_oldbufptr))
6269 context = PL_oldbufptr;
6270 contlen = PL_bufptr - PL_oldbufptr;
6272 else if (yychar > 255)
6273 where = "next token ???";
6274 else if ((yychar & 127) == 127) {
6275 if (PL_lex_state == LEX_NORMAL ||
6276 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6277 where = "at end of line";
6278 else if (PL_lex_inpat)
6279 where = "within pattern";
6281 where = "within string";
6284 SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6286 sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6287 else if (isPRINT_LC(yychar))
6288 sv_catpvf(where_sv, "%c", yychar);
6290 sv_catpvf(where_sv, "\\%03o", yychar & 255);
6291 where = SvPVX(where_sv);
6293 msg = sv_2mortal(newSVpv(s, 0));
6294 sv_catpvf(msg, " at %_ line %ld, ",
6295 GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6297 sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6299 sv_catpvf(msg, "%s\n", where);
6300 if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6302 " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6303 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6308 else if (PL_in_eval)
6309 sv_catsv(ERRSV, msg);
6311 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6312 if (++PL_error_count >= 10)
6313 croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6315 PL_in_my_stash = Nullhv;