3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It all comes from here, the stench and the peril." --Frodo
16 * This file is the lexer for Perl. It's closely linked to the
19 * The main routine is yylex(), which returns the next token.
23 #define PERL_IN_TOKE_C
26 #define yychar (*PL_yycharp)
27 #define yylval (*PL_yylvalp)
29 static char ident_too_long[] = "Identifier too long";
30 static char c_without_g[] = "Use of /c modifier is meaningless without /g";
31 static char c_in_subst[] = "Use of /c modifier is meaningless in s///";
33 static void restore_rsfp(pTHX_ void *f);
34 #ifndef PERL_NO_UTF16_FILTER
35 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
36 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
39 #define XFAKEBRACK 128
42 #ifdef USE_UTF8_SCRIPTS
43 # define UTF (!IN_BYTES)
45 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
48 /* In variables named $^X, these are the legal values for X.
49 * 1999-02-27 mjd-perl-patch@plover.com */
50 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
52 /* On MacOS, respect nonbreaking spaces */
53 #ifdef MACOS_TRADITIONAL
54 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
56 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
59 /* LEX_* are values for PL_lex_state, the state of the lexer.
60 * They are arranged oddly so that the guard on the switch statement
61 * can get by with a single comparison (if the compiler is smart enough).
64 /* #define LEX_NOTPARSING 11 is done in perl.h. */
67 #define LEX_INTERPNORMAL 9
68 #define LEX_INTERPCASEMOD 8
69 #define LEX_INTERPPUSH 7
70 #define LEX_INTERPSTART 6
71 #define LEX_INTERPEND 5
72 #define LEX_INTERPENDMAYBE 4
73 #define LEX_INTERPCONCAT 3
74 #define LEX_INTERPCONST 2
75 #define LEX_FORMLINE 1
76 #define LEX_KNOWNEXT 0
79 static char* lex_state_names[] = {
100 /* CLINE is a macro that ensures PL_copline has a sane value */
105 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
108 * Convenience functions to return different tokens and prime the
109 * lexer for the next token. They all take an argument.
111 * TOKEN : generic token (used for '(', DOLSHARP, etc)
112 * OPERATOR : generic operator
113 * AOPERATOR : assignment operator
114 * PREBLOCK : beginning the block after an if, while, foreach, ...
115 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
116 * PREREF : *EXPR where EXPR is not a simple identifier
117 * TERM : expression term
118 * LOOPX : loop exiting command (goto, last, dump, etc)
119 * FTST : file test operator
120 * FUN0 : zero-argument function
121 * FUN1 : not used, except for not, which isn't a UNIOP
122 * BOop : bitwise or or xor
124 * SHop : shift operator
125 * PWop : power operator
126 * PMop : pattern-matching operator
127 * Aop : addition-level operator
128 * Mop : multiplication-level operator
129 * Eop : equality-testing operator
130 * Rop : relational operator <= != gt
132 * Also see LOP and lop() below.
135 #ifdef DEBUGGING /* Serve -DT. */
136 # define REPORT(retval) tokereport(s,(int)retval)
138 # define REPORT(retval) (retval)
141 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
142 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
143 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
144 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
145 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
146 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
147 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
148 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
149 #define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
150 #define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
151 #define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
152 #define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
153 #define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
154 #define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
155 #define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
156 #define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
157 #define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
158 #define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
159 #define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
160 #define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
162 /* This bit of chicanery makes a unary function followed by
163 * a parenthesis into a function with one argument, highest precedence.
164 * The UNIDOR macro is for unary functions that can be followed by the //
165 * operator (such as C<shift // 0>).
167 #define UNI2(f,x) return ( \
171 PL_last_uni = PL_oldbufptr, \
172 PL_last_lop_op = f, \
174 (*s == '(' || (s = skipspace(s), *s == '(') \
175 ? (int)FUNC1 : (int)UNIOP)))
176 #define UNI(f) UNI2(f,XTERM)
177 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
179 #define UNIBRACK(f) return ( \
182 PL_last_uni = PL_oldbufptr, \
184 (*s == '(' || (s = skipspace(s), *s == '(') \
185 ? (int)FUNC1 : (int)UNIOP)))
187 /* grandfather return to old style */
188 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
192 /* how to interpret the yylval associated with the token */
196 TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
202 static struct debug_tokens { int token, type; char *name;} debug_tokens[] =
204 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
205 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
206 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
207 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
208 { ARROW, TOKENTYPE_NONE, "ARROW" },
209 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
210 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
211 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
212 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
213 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
214 { DO, TOKENTYPE_NONE, "DO" },
215 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
216 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
217 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
218 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
219 { ELSE, TOKENTYPE_NONE, "ELSE" },
220 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
221 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
222 { FOR, TOKENTYPE_IVAL, "FOR" },
223 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
224 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
225 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
226 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
227 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
228 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
229 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
230 { IF, TOKENTYPE_IVAL, "IF" },
231 { LABEL, TOKENTYPE_PVAL, "LABEL" },
232 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
233 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
234 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
235 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
236 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
237 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
238 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
239 { MY, TOKENTYPE_IVAL, "MY" },
240 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
241 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
242 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
243 { OROP, TOKENTYPE_IVAL, "OROP" },
244 { OROR, TOKENTYPE_NONE, "OROR" },
245 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
246 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
247 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
248 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
249 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
250 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
251 { PREINC, TOKENTYPE_NONE, "PREINC" },
252 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
253 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
254 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
255 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
256 { SUB, TOKENTYPE_NONE, "SUB" },
257 { THING, TOKENTYPE_OPVAL, "THING" },
258 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
259 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
260 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
261 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
262 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
263 { USE, TOKENTYPE_IVAL, "USE" },
264 { WHILE, TOKENTYPE_IVAL, "WHILE" },
265 { WORD, TOKENTYPE_OPVAL, "WORD" },
266 { 0, TOKENTYPE_NONE, 0 }
269 /* dump the returned token in rv, plus any optional arg in yylval */
272 S_tokereport(pTHX_ char* s, I32 rv)
276 enum token_type type = TOKENTYPE_NONE;
277 struct debug_tokens *p;
278 SV* report = NEWSV(0, 60);
280 Perl_sv_catpvf(aTHX_ report, "<== ");
282 for (p = debug_tokens; p->token; p++) {
283 if (p->token == (int)rv) {
290 Perl_sv_catpvf(aTHX_ report, "%s", name);
291 else if ((char)rv > ' ' && (char)rv < '~')
292 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
294 Perl_sv_catpvf(aTHX_ report, "EOF");
296 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
299 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
302 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", yylval.ival);
304 case TOKENTYPE_OPNUM:
305 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
306 PL_op_name[yylval.ival]);
309 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
311 case TOKENTYPE_OPVAL:
313 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
314 PL_op_name[yylval.opval->op_type]);
316 Perl_sv_catpv(aTHX_ report, "(opval=null)");
319 Perl_sv_catpvf(aTHX_ report, " at line %d [", CopLINE(PL_curcop));
320 if (s - PL_bufptr > 0)
321 sv_catpvn(report, PL_bufptr, s - PL_bufptr);
323 if (PL_oldbufptr && *PL_oldbufptr)
324 sv_catpv(report, PL_tokenbuf);
326 PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen(report));
336 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
337 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
341 S_ao(pTHX_ int toketype)
343 if (*PL_bufptr == '=') {
345 if (toketype == ANDAND)
346 yylval.ival = OP_ANDASSIGN;
347 else if (toketype == OROR)
348 yylval.ival = OP_ORASSIGN;
349 else if (toketype == DORDOR)
350 yylval.ival = OP_DORASSIGN;
358 * When Perl expects an operator and finds something else, no_op
359 * prints the warning. It always prints "<something> found where
360 * operator expected. It prints "Missing semicolon on previous line?"
361 * if the surprise occurs at the start of the line. "do you need to
362 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
363 * where the compiler doesn't know if foo is a method call or a function.
364 * It prints "Missing operator before end of line" if there's nothing
365 * after the missing operator, or "... before <...>" if there is something
366 * after the missing operator.
370 S_no_op(pTHX_ char *what, char *s)
372 char *oldbp = PL_bufptr;
373 bool is_first = (PL_oldbufptr == PL_linestart);
379 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
380 if (ckWARN_d(WARN_SYNTAX)) {
382 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
383 "\t(Missing semicolon on previous line?)\n");
384 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
386 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
387 if (t < PL_bufptr && isSPACE(*t))
388 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
389 "\t(Do you need to predeclare %.*s?)\n",
390 t - PL_oldoldbufptr, PL_oldoldbufptr);
394 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
395 "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
403 * Complain about missing quote/regexp/heredoc terminator.
404 * If it's called with (char *)NULL then it cauterizes the line buffer.
405 * If we're in a delimited string and the delimiter is a control
406 * character, it's reformatted into a two-char sequence like ^C.
411 S_missingterm(pTHX_ char *s)
416 char *nl = strrchr(s,'\n');
422 iscntrl(PL_multi_close)
424 PL_multi_close < 32 || PL_multi_close == 127
428 tmpbuf[1] = toCTRL(PL_multi_close);
434 *tmpbuf = (char)PL_multi_close;
438 q = strchr(s,'"') ? '\'' : '"';
439 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
447 Perl_deprecate(pTHX_ char *s)
449 if (ckWARN(WARN_DEPRECATED))
450 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
454 Perl_deprecate_old(pTHX_ char *s)
456 /* This function should NOT be called for any new deprecated warnings */
457 /* Use Perl_deprecate instead */
459 /* It is here to maintain backward compatibility with the pre-5.8 */
460 /* warnings category hierarchy. The "deprecated" category used to */
461 /* live under the "syntax" category. It is now a top-level category */
462 /* in its own right. */
464 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
465 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
466 "Use of %s is deprecated", s);
471 * Deprecate a comma-less variable list.
477 deprecate_old("comma-less variable list");
481 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
482 * utf16-to-utf8-reversed.
485 #ifdef PERL_CR_FILTER
489 register char *s = SvPVX(sv);
490 register char *e = s + SvCUR(sv);
491 /* outer loop optimized to do nothing if there are no CR-LFs */
493 if (*s++ == '\r' && *s == '\n') {
494 /* hit a CR-LF, need to copy the rest */
495 register char *d = s - 1;
498 if (*s == '\r' && s[1] == '\n')
509 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
511 I32 count = FILTER_READ(idx+1, sv, maxlen);
512 if (count > 0 && !maxlen)
520 * Initialize variables. Uses the Perl save_stack to save its state (for
521 * recursive calls to the parser).
525 Perl_lex_start(pTHX_ SV *line)
530 SAVEI32(PL_lex_dojoin);
531 SAVEI32(PL_lex_brackets);
532 SAVEI32(PL_lex_casemods);
533 SAVEI32(PL_lex_starts);
534 SAVEI32(PL_lex_state);
535 SAVEVPTR(PL_lex_inpat);
536 SAVEI32(PL_lex_inwhat);
537 if (PL_lex_state == LEX_KNOWNEXT) {
538 I32 toke = PL_nexttoke;
539 while (--toke >= 0) {
540 SAVEI32(PL_nexttype[toke]);
541 SAVEVPTR(PL_nextval[toke]);
543 SAVEI32(PL_nexttoke);
545 SAVECOPLINE(PL_curcop);
548 SAVEPPTR(PL_oldbufptr);
549 SAVEPPTR(PL_oldoldbufptr);
550 SAVEPPTR(PL_last_lop);
551 SAVEPPTR(PL_last_uni);
552 SAVEPPTR(PL_linestart);
553 SAVESPTR(PL_linestr);
554 SAVEGENERICPV(PL_lex_brackstack);
555 SAVEGENERICPV(PL_lex_casestack);
556 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
557 SAVESPTR(PL_lex_stuff);
558 SAVEI32(PL_lex_defer);
559 SAVEI32(PL_sublex_info.sub_inwhat);
560 SAVESPTR(PL_lex_repl);
562 SAVEINT(PL_lex_expect);
564 PL_lex_state = LEX_NORMAL;
568 New(899, PL_lex_brackstack, 120, char);
569 New(899, PL_lex_casestack, 12, char);
571 *PL_lex_casestack = '\0';
574 PL_lex_stuff = Nullsv;
575 PL_lex_repl = Nullsv;
579 PL_sublex_info.sub_inwhat = 0;
581 if (SvREADONLY(PL_linestr))
582 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
583 s = SvPV(PL_linestr, len);
584 if (!len || s[len-1] != ';') {
585 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
586 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
587 sv_catpvn(PL_linestr, "\n;", 2);
589 SvTEMP_off(PL_linestr);
590 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
591 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
592 PL_last_lop = PL_last_uni = Nullch;
598 * Finalizer for lexing operations. Must be called when the parser is
599 * done with the lexer.
605 PL_doextract = FALSE;
610 * This subroutine has nothing to do with tilting, whether at windmills
611 * or pinball tables. Its name is short for "increment line". It
612 * increments the current line number in CopLINE(PL_curcop) and checks
613 * to see whether the line starts with a comment of the form
614 * # line 500 "foo.pm"
615 * If so, it sets the current line number and file to the values in the comment.
619 S_incline(pTHX_ char *s)
626 CopLINE_inc(PL_curcop);
629 while (SPACE_OR_TAB(*s)) s++;
630 if (strnEQ(s, "line", 4))
634 if (SPACE_OR_TAB(*s))
638 while (SPACE_OR_TAB(*s)) s++;
644 while (SPACE_OR_TAB(*s))
646 if (*s == '"' && (t = strchr(s+1, '"'))) {
651 for (t = s; !isSPACE(*t); t++) ;
654 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
656 if (*e != '\n' && *e != '\0')
657 return; /* false alarm */
662 CopFILE_free(PL_curcop);
663 CopFILE_set(PL_curcop, s);
666 CopLINE_set(PL_curcop, atoi(n)-1);
671 * Called to gobble the appropriate amount and type of whitespace.
672 * Skips comments as well.
676 S_skipspace(pTHX_ register char *s)
678 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
679 while (s < PL_bufend && SPACE_OR_TAB(*s))
685 SSize_t oldprevlen, oldoldprevlen;
686 SSize_t oldloplen = 0, oldunilen = 0;
687 while (s < PL_bufend && isSPACE(*s)) {
688 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
693 if (s < PL_bufend && *s == '#') {
694 while (s < PL_bufend && *s != '\n')
698 if (PL_in_eval && !PL_rsfp) {
705 /* only continue to recharge the buffer if we're at the end
706 * of the buffer, we're not reading from a source filter, and
707 * we're in normal lexing mode
709 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
710 PL_lex_state == LEX_FORMLINE)
713 /* try to recharge the buffer */
714 if ((s = filter_gets(PL_linestr, PL_rsfp,
715 (prevlen = SvCUR(PL_linestr)))) == Nullch)
717 /* end of file. Add on the -p or -n magic */
720 ";}continue{print or die qq(-p destination: $!\\n);}");
721 PL_minus_n = PL_minus_p = 0;
723 else if (PL_minus_n) {
724 sv_setpvn(PL_linestr, ";}", 2);
728 sv_setpvn(PL_linestr,";", 1);
730 /* reset variables for next time we lex */
731 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
733 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
734 PL_last_lop = PL_last_uni = Nullch;
736 /* Close the filehandle. Could be from -P preprocessor,
737 * STDIN, or a regular file. If we were reading code from
738 * STDIN (because the commandline held no -e or filename)
739 * then we don't close it, we reset it so the code can
740 * read from STDIN too.
743 if (PL_preprocess && !PL_in_eval)
744 (void)PerlProc_pclose(PL_rsfp);
745 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
746 PerlIO_clearerr(PL_rsfp);
748 (void)PerlIO_close(PL_rsfp);
753 /* not at end of file, so we only read another line */
754 /* make corresponding updates to old pointers, for yyerror() */
755 oldprevlen = PL_oldbufptr - PL_bufend;
756 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
758 oldunilen = PL_last_uni - PL_bufend;
760 oldloplen = PL_last_lop - PL_bufend;
761 PL_linestart = PL_bufptr = s + prevlen;
762 PL_bufend = s + SvCUR(PL_linestr);
764 PL_oldbufptr = s + oldprevlen;
765 PL_oldoldbufptr = s + oldoldprevlen;
767 PL_last_uni = s + oldunilen;
769 PL_last_lop = s + oldloplen;
772 /* debugger active and we're not compiling the debugger code,
773 * so store the line into the debugger's array of lines
775 if (PERLDB_LINE && PL_curstash != PL_debstash) {
776 SV *sv = NEWSV(85,0);
778 sv_upgrade(sv, SVt_PVMG);
779 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
782 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
789 * Check the unary operators to ensure there's no ambiguity in how they're
790 * used. An ambiguous piece of code would be:
792 * This doesn't mean rand() + 5. Because rand() is a unary operator,
793 * the +5 is its argument.
802 if (PL_oldoldbufptr != PL_last_uni)
804 while (isSPACE(*PL_last_uni))
806 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
807 if ((t = strchr(s, '(')) && t < PL_bufptr)
809 if (ckWARN_d(WARN_AMBIGUOUS)){
812 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
813 "Warning: Use of \"%s\" without parentheses is ambiguous",
820 * LOP : macro to build a list operator. Its behaviour has been replaced
821 * with a subroutine, S_lop() for which LOP is just another name.
824 #define LOP(f,x) return lop(f,x,s)
828 * Build a list operator (or something that might be one). The rules:
829 * - if we have a next token, then it's a list operator [why?]
830 * - if the next thing is an opening paren, then it's a function
831 * - else it's a list operator
835 S_lop(pTHX_ I32 f, int x, char *s)
841 PL_last_lop = PL_oldbufptr;
842 PL_last_lop_op = (OPCODE)f;
844 return REPORT(LSTOP);
851 return REPORT(LSTOP);
856 * When the lexer realizes it knows the next token (for instance,
857 * it is reordering tokens for the parser) then it can call S_force_next
858 * to know what token to return the next time the lexer is called. Caller
859 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
860 * handles the token correctly.
864 S_force_next(pTHX_ I32 type)
866 PL_nexttype[PL_nexttoke] = type;
868 if (PL_lex_state != LEX_KNOWNEXT) {
869 PL_lex_defer = PL_lex_state;
870 PL_lex_expect = PL_expect;
871 PL_lex_state = LEX_KNOWNEXT;
877 * When the lexer knows the next thing is a word (for instance, it has
878 * just seen -> and it knows that the next char is a word char, then
879 * it calls S_force_word to stick the next word into the PL_next lookahead.
882 * char *start : buffer position (must be within PL_linestr)
883 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
884 * int check_keyword : if true, Perl checks to make sure the word isn't
885 * a keyword (do this if the word is a label, e.g. goto FOO)
886 * int allow_pack : if true, : characters will also be allowed (require,
888 * int allow_initial_tick : used by the "sub" lexer only.
892 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
897 start = skipspace(start);
899 if (isIDFIRST_lazy_if(s,UTF) ||
900 (allow_pack && *s == ':') ||
901 (allow_initial_tick && *s == '\'') )
903 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
904 if (check_keyword && keyword(PL_tokenbuf, len))
906 if (token == METHOD) {
911 PL_expect = XOPERATOR;
914 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
915 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
916 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
917 SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke].opval)->op_sv);
925 * Called when the lexer wants $foo *foo &foo etc, but the program
926 * text only contains the "foo" portion. The first argument is a pointer
927 * to the "foo", and the second argument is the type symbol to prefix.
928 * Forces the next token to be a "WORD".
929 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
933 S_force_ident(pTHX_ register char *s, int kind)
936 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
937 PL_nextval[PL_nexttoke].opval = o;
940 o->op_private = OPpCONST_ENTERED;
941 /* XXX see note in pp_entereval() for why we forgo typo
942 warnings if the symbol must be introduced in an eval.
944 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
945 kind == '$' ? SVt_PV :
946 kind == '@' ? SVt_PVAV :
947 kind == '%' ? SVt_PVHV :
955 Perl_str_to_version(pTHX_ SV *sv)
960 char *start = SvPVx(sv,len);
961 bool utf = SvUTF8(sv) ? TRUE : FALSE;
962 char *end = start + len;
963 while (start < end) {
967 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
972 retval += ((NV)n)/nshift;
981 * Forces the next token to be a version number.
982 * If the next token appears to be an invalid version number, (e.g. "v2b"),
983 * and if "guessing" is TRUE, then no new token is created (and the caller
984 * must use an alternative parsing method).
988 S_force_version(pTHX_ char *s, int guessing)
990 OP *version = Nullop;
999 while (isDIGIT(*d) || *d == '_' || *d == '.')
1001 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1003 s = scan_num(s, &yylval);
1004 version = yylval.opval;
1005 ver = cSVOPx(version)->op_sv;
1006 if (SvPOK(ver) && !SvNIOK(ver)) {
1007 (void)SvUPGRADE(ver, SVt_PVNV);
1008 SvNVX(ver) = str_to_version(ver);
1009 SvNOK_on(ver); /* hint that it is a version */
1016 /* NOTE: The parser sees the package name and the VERSION swapped */
1017 PL_nextval[PL_nexttoke].opval = version;
1025 * Tokenize a quoted string passed in as an SV. It finds the next
1026 * chunk, up to end of string or a backslash. It may make a new
1027 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1032 S_tokeq(pTHX_ SV *sv)
1035 register char *send;
1043 s = SvPV_force(sv, len);
1044 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1047 while (s < send && *s != '\\')
1052 if ( PL_hints & HINT_NEW_STRING ) {
1053 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
1059 if (s + 1 < send && (s[1] == '\\'))
1060 s++; /* all that, just for this */
1065 SvCUR_set(sv, d - SvPVX(sv));
1067 if ( PL_hints & HINT_NEW_STRING )
1068 return new_constant(NULL, 0, "q", sv, pv, "q");
1073 * Now come three functions related to double-quote context,
1074 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1075 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1076 * interact with PL_lex_state, and create fake ( ... ) argument lists
1077 * to handle functions and concatenation.
1078 * They assume that whoever calls them will be setting up a fake
1079 * join call, because each subthing puts a ',' after it. This lets
1082 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1084 * (I'm not sure whether the spurious commas at the end of lcfirst's
1085 * arguments and join's arguments are created or not).
1090 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1092 * Pattern matching will set PL_lex_op to the pattern-matching op to
1093 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1095 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1097 * Everything else becomes a FUNC.
1099 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1100 * had an OP_CONST or OP_READLINE). This just sets us up for a
1101 * call to S_sublex_push().
1105 S_sublex_start(pTHX)
1107 register I32 op_type = yylval.ival;
1109 if (op_type == OP_NULL) {
1110 yylval.opval = PL_lex_op;
1114 if (op_type == OP_CONST || op_type == OP_READLINE) {
1115 SV *sv = tokeq(PL_lex_stuff);
1117 if (SvTYPE(sv) == SVt_PVIV) {
1118 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1124 nsv = newSVpvn(p, len);
1130 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1131 PL_lex_stuff = Nullsv;
1132 /* Allow <FH> // "foo" */
1133 if (op_type == OP_READLINE)
1134 PL_expect = XTERMORDORDOR;
1138 PL_sublex_info.super_state = PL_lex_state;
1139 PL_sublex_info.sub_inwhat = op_type;
1140 PL_sublex_info.sub_op = PL_lex_op;
1141 PL_lex_state = LEX_INTERPPUSH;
1145 yylval.opval = PL_lex_op;
1155 * Create a new scope to save the lexing state. The scope will be
1156 * ended in S_sublex_done. Returns a '(', starting the function arguments
1157 * to the uc, lc, etc. found before.
1158 * Sets PL_lex_state to LEX_INTERPCONCAT.
1166 PL_lex_state = PL_sublex_info.super_state;
1167 SAVEI32(PL_lex_dojoin);
1168 SAVEI32(PL_lex_brackets);
1169 SAVEI32(PL_lex_casemods);
1170 SAVEI32(PL_lex_starts);
1171 SAVEI32(PL_lex_state);
1172 SAVEVPTR(PL_lex_inpat);
1173 SAVEI32(PL_lex_inwhat);
1174 SAVECOPLINE(PL_curcop);
1175 SAVEPPTR(PL_bufptr);
1176 SAVEPPTR(PL_bufend);
1177 SAVEPPTR(PL_oldbufptr);
1178 SAVEPPTR(PL_oldoldbufptr);
1179 SAVEPPTR(PL_last_lop);
1180 SAVEPPTR(PL_last_uni);
1181 SAVEPPTR(PL_linestart);
1182 SAVESPTR(PL_linestr);
1183 SAVEGENERICPV(PL_lex_brackstack);
1184 SAVEGENERICPV(PL_lex_casestack);
1186 PL_linestr = PL_lex_stuff;
1187 PL_lex_stuff = Nullsv;
1189 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1190 = SvPVX(PL_linestr);
1191 PL_bufend += SvCUR(PL_linestr);
1192 PL_last_lop = PL_last_uni = Nullch;
1193 SAVEFREESV(PL_linestr);
1195 PL_lex_dojoin = FALSE;
1196 PL_lex_brackets = 0;
1197 New(899, PL_lex_brackstack, 120, char);
1198 New(899, PL_lex_casestack, 12, char);
1199 PL_lex_casemods = 0;
1200 *PL_lex_casestack = '\0';
1202 PL_lex_state = LEX_INTERPCONCAT;
1203 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1205 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1206 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1207 PL_lex_inpat = PL_sublex_info.sub_op;
1209 PL_lex_inpat = Nullop;
1216 * Restores lexer state after a S_sublex_push.
1222 if (!PL_lex_starts++) {
1223 SV *sv = newSVpvn("",0);
1224 if (SvUTF8(PL_linestr))
1226 PL_expect = XOPERATOR;
1227 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1231 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1232 PL_lex_state = LEX_INTERPCASEMOD;
1236 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1237 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1238 PL_linestr = PL_lex_repl;
1240 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1241 PL_bufend += SvCUR(PL_linestr);
1242 PL_last_lop = PL_last_uni = Nullch;
1243 SAVEFREESV(PL_linestr);
1244 PL_lex_dojoin = FALSE;
1245 PL_lex_brackets = 0;
1246 PL_lex_casemods = 0;
1247 *PL_lex_casestack = '\0';
1249 if (SvEVALED(PL_lex_repl)) {
1250 PL_lex_state = LEX_INTERPNORMAL;
1252 /* we don't clear PL_lex_repl here, so that we can check later
1253 whether this is an evalled subst; that means we rely on the
1254 logic to ensure sublex_done() is called again only via the
1255 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1258 PL_lex_state = LEX_INTERPCONCAT;
1259 PL_lex_repl = Nullsv;
1265 PL_bufend = SvPVX(PL_linestr);
1266 PL_bufend += SvCUR(PL_linestr);
1267 PL_expect = XOPERATOR;
1268 PL_sublex_info.sub_inwhat = 0;
1276 Extracts a pattern, double-quoted string, or transliteration. This
1279 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1280 processing a pattern (PL_lex_inpat is true), a transliteration
1281 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1283 Returns a pointer to the character scanned up to. Iff this is
1284 advanced from the start pointer supplied (ie if anything was
1285 successfully parsed), will leave an OP for the substring scanned
1286 in yylval. Caller must intuit reason for not parsing further
1287 by looking at the next characters herself.
1291 double-quoted style: \r and \n
1292 regexp special ones: \D \s
1294 backrefs: \1 (deprecated in substitution replacements)
1295 case and quoting: \U \Q \E
1296 stops on @ and $, but not for $ as tail anchor
1298 In transliterations:
1299 characters are VERY literal, except for - not at the start or end
1300 of the string, which indicates a range. scan_const expands the
1301 range to the full set of intermediate characters.
1303 In double-quoted strings:
1305 double-quoted style: \r and \n
1307 backrefs: \1 (deprecated)
1308 case and quoting: \U \Q \E
1311 scan_const does *not* construct ops to handle interpolated strings.
1312 It stops processing as soon as it finds an embedded $ or @ variable
1313 and leaves it to the caller to work out what's going on.
1315 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1317 $ in pattern could be $foo or could be tail anchor. Assumption:
1318 it's a tail anchor if $ is the last thing in the string, or if it's
1319 followed by one of ")| \n\t"
1321 \1 (backreferences) are turned into $1
1323 The structure of the code is
1324 while (there's a character to process) {
1325 handle transliteration ranges
1326 skip regexp comments
1327 skip # initiated comments in //x patterns
1328 check for embedded @foo
1329 check for embedded scalars
1331 leave intact backslashes from leave (below)
1332 deprecate \1 in strings and sub replacements
1333 handle string-changing backslashes \l \U \Q \E, etc.
1334 switch (what was escaped) {
1335 handle - in a transliteration (becomes a literal -)
1336 handle \132 octal characters
1337 handle 0x15 hex characters
1338 handle \cV (control V)
1339 handle printf backslashes (\f, \r, \n, etc)
1341 } (end if backslash)
1342 } (end while character to read)
1347 S_scan_const(pTHX_ char *start)
1349 register char *send = PL_bufend; /* end of the constant */
1350 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1351 register char *s = start; /* start of the constant */
1352 register char *d = SvPVX(sv); /* destination for copies */
1353 bool dorange = FALSE; /* are we in a translit range? */
1354 bool didrange = FALSE; /* did we just finish a range? */
1355 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1356 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1359 const char *leaveit = /* set of acceptably-backslashed characters */
1361 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1364 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1365 /* If we are doing a trans and we know we want UTF8 set expectation */
1366 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1367 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1371 while (s < send || dorange) {
1372 /* get transliterations out of the way (they're most literal) */
1373 if (PL_lex_inwhat == OP_TRANS) {
1374 /* expand a range A-Z to the full set of characters. AIE! */
1376 I32 i; /* current expanded character */
1377 I32 min; /* first character in range */
1378 I32 max; /* last character in range */
1381 char *c = (char*)utf8_hop((U8*)d, -1);
1385 *c = (char)UTF_TO_NATIVE(0xff);
1386 /* mark the range as done, and continue */
1392 i = d - SvPVX(sv); /* remember current offset */
1393 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1394 d = SvPVX(sv) + i; /* refresh d after realloc */
1395 d -= 2; /* eat the first char and the - */
1397 min = (U8)*d; /* first char in range */
1398 max = (U8)d[1]; /* last char in range */
1402 "Invalid range \"%c-%c\" in transliteration operator",
1403 (char)min, (char)max);
1407 if ((isLOWER(min) && isLOWER(max)) ||
1408 (isUPPER(min) && isUPPER(max))) {
1410 for (i = min; i <= max; i++)
1412 *d++ = NATIVE_TO_NEED(has_utf8,i);
1414 for (i = min; i <= max; i++)
1416 *d++ = NATIVE_TO_NEED(has_utf8,i);
1421 for (i = min; i <= max; i++)
1424 /* mark the range as done, and continue */
1430 /* range begins (ignore - as first or last char) */
1431 else if (*s == '-' && s+1 < send && s != start) {
1433 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1436 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1448 /* if we get here, we're not doing a transliteration */
1450 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1451 except for the last char, which will be done separately. */
1452 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1454 while (s+1 < send && *s != ')')
1455 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1457 else if (s[2] == '{' /* This should match regcomp.c */
1458 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1461 char *regparse = s + (s[2] == '{' ? 3 : 4);
1464 while (count && (c = *regparse)) {
1465 if (c == '\\' && regparse[1])
1473 if (*regparse != ')')
1474 regparse--; /* Leave one char for continuation. */
1475 while (s < regparse)
1476 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1480 /* likewise skip #-initiated comments in //x patterns */
1481 else if (*s == '#' && PL_lex_inpat &&
1482 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1483 while (s+1 < send && *s != '\n')
1484 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1487 /* check for embedded arrays
1488 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1490 else if (*s == '@' && s[1]
1491 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1494 /* check for embedded scalars. only stop if we're sure it's a
1497 else if (*s == '$') {
1498 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1500 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1501 break; /* in regexp, $ might be tail anchor */
1504 /* End of else if chain - OP_TRANS rejoin rest */
1507 if (*s == '\\' && s+1 < send) {
1510 /* some backslashes we leave behind */
1511 if (*leaveit && *s && strchr(leaveit, *s)) {
1512 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1513 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1517 /* deprecate \1 in strings and substitution replacements */
1518 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1519 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1521 if (ckWARN(WARN_SYNTAX))
1522 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1527 /* string-change backslash escapes */
1528 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1533 /* if we get here, it's either a quoted -, or a digit */
1536 /* quoted - in transliterations */
1538 if (PL_lex_inwhat == OP_TRANS) {
1545 if (ckWARN(WARN_MISC) &&
1548 Perl_warner(aTHX_ packWARN(WARN_MISC),
1549 "Unrecognized escape \\%c passed through",
1551 /* default action is to copy the quoted character */
1552 goto default_action;
1555 /* \132 indicates an octal constant */
1556 case '0': case '1': case '2': case '3':
1557 case '4': case '5': case '6': case '7':
1561 uv = grok_oct(s, &len, &flags, NULL);
1564 goto NUM_ESCAPE_INSERT;
1566 /* \x24 indicates a hex constant */
1570 char* e = strchr(s, '}');
1571 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1572 PERL_SCAN_DISALLOW_PREFIX;
1577 yyerror("Missing right brace on \\x{}");
1581 uv = grok_hex(s, &len, &flags, NULL);
1587 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1588 uv = grok_hex(s, &len, &flags, NULL);
1594 /* Insert oct or hex escaped character.
1595 * There will always enough room in sv since such
1596 * escapes will be longer than any UTF-8 sequence
1597 * they can end up as. */
1599 /* We need to map to chars to ASCII before doing the tests
1602 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1603 if (!has_utf8 && uv > 255) {
1604 /* Might need to recode whatever we have
1605 * accumulated so far if it contains any
1608 * (Can't we keep track of that and avoid
1609 * this rescan? --jhi)
1613 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1614 if (!NATIVE_IS_INVARIANT(*c)) {
1619 STRLEN offset = d - SvPVX(sv);
1621 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1625 while (src >= (U8 *)SvPVX(sv)) {
1626 if (!NATIVE_IS_INVARIANT(*src)) {
1627 U8 ch = NATIVE_TO_ASCII(*src);
1628 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1629 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1639 if (has_utf8 || uv > 255) {
1640 d = (char*)uvchr_to_utf8((U8*)d, uv);
1642 if (PL_lex_inwhat == OP_TRANS &&
1643 PL_sublex_info.sub_op) {
1644 PL_sublex_info.sub_op->op_private |=
1645 (PL_lex_repl ? OPpTRANS_FROM_UTF
1658 /* \N{LATIN SMALL LETTER A} is a named character */
1662 char* e = strchr(s, '}');
1668 yyerror("Missing right brace on \\N{}");
1672 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1674 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1675 PERL_SCAN_DISALLOW_PREFIX;
1678 uv = grok_hex(s, &len, &flags, NULL);
1680 goto NUM_ESCAPE_INSERT;
1682 res = newSVpvn(s + 1, e - s - 1);
1683 res = new_constant( Nullch, 0, "charnames",
1684 res, Nullsv, "\\N{...}" );
1686 sv_utf8_upgrade(res);
1687 str = SvPV(res,len);
1688 #ifdef EBCDIC_NEVER_MIND
1689 /* charnames uses pack U and that has been
1690 * recently changed to do the below uni->native
1691 * mapping, so this would be redundant (and wrong,
1692 * the code point would be doubly converted).
1693 * But leave this in just in case the pack U change
1694 * gets revoked, but the semantics is still
1695 * desireable for charnames. --jhi */
1697 UV uv = utf8_to_uvchr((U8*)str, 0);
1700 U8 tmpbuf[UTF8_MAXLEN+1], *d;
1702 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1703 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1704 str = SvPV(res, len);
1708 if (!has_utf8 && SvUTF8(res)) {
1709 char *ostart = SvPVX(sv);
1710 SvCUR_set(sv, d - ostart);
1713 sv_utf8_upgrade(sv);
1714 /* this just broke our allocation above... */
1715 SvGROW(sv, (STRLEN)(send - start));
1716 d = SvPVX(sv) + SvCUR(sv);
1719 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1720 char *odest = SvPVX(sv);
1722 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1723 d = SvPVX(sv) + (d - odest);
1725 Copy(str, d, len, char);
1732 yyerror("Missing braces on \\N{}");
1735 /* \c is a control character */
1744 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1747 yyerror("Missing control char name in \\c");
1751 /* printf-style backslashes, formfeeds, newlines, etc */
1753 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1756 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1759 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1762 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1765 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1768 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1771 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1777 } /* end if (backslash) */
1780 /* If we started with encoded form, or already know we want it
1781 and then encode the next character */
1782 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1784 UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1785 STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1788 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1789 STRLEN off = d - SvPVX(sv);
1790 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1792 d = (char*)uvchr_to_utf8((U8*)d, uv);
1796 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1798 } /* while loop to process each character */
1800 /* terminate the string and set up the sv */
1802 SvCUR_set(sv, d - SvPVX(sv));
1803 if (SvCUR(sv) >= SvLEN(sv))
1804 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1807 if (PL_encoding && !has_utf8) {
1808 sv_recode_to_utf8(sv, PL_encoding);
1814 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1815 PL_sublex_info.sub_op->op_private |=
1816 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1820 /* shrink the sv if we allocated more than we used */
1821 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1822 SvLEN_set(sv, SvCUR(sv) + 1);
1823 Renew(SvPVX(sv), SvLEN(sv), char);
1826 /* return the substring (via yylval) only if we parsed anything */
1827 if (s > PL_bufptr) {
1828 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1829 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1831 ( PL_lex_inwhat == OP_TRANS
1833 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1836 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1843 * Returns TRUE if there's more to the expression (e.g., a subscript),
1846 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1848 * ->[ and ->{ return TRUE
1849 * { and [ outside a pattern are always subscripts, so return TRUE
1850 * if we're outside a pattern and it's not { or [, then return FALSE
1851 * if we're in a pattern and the first char is a {
1852 * {4,5} (any digits around the comma) returns FALSE
1853 * if we're in a pattern and the first char is a [
1855 * [SOMETHING] has a funky algorithm to decide whether it's a
1856 * character class or not. It has to deal with things like
1857 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1858 * anything else returns TRUE
1861 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1864 S_intuit_more(pTHX_ register char *s)
1866 if (PL_lex_brackets)
1868 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1870 if (*s != '{' && *s != '[')
1875 /* In a pattern, so maybe we have {n,m}. */
1892 /* On the other hand, maybe we have a character class */
1895 if (*s == ']' || *s == '^')
1898 /* this is terrifying, and it works */
1899 int weight = 2; /* let's weigh the evidence */
1901 unsigned char un_char = 255, last_un_char;
1902 char *send = strchr(s,']');
1903 char tmpbuf[sizeof PL_tokenbuf * 4];
1905 if (!send) /* has to be an expression */
1908 Zero(seen,256,char);
1911 else if (isDIGIT(*s)) {
1913 if (isDIGIT(s[1]) && s[2] == ']')
1919 for (; s < send; s++) {
1920 last_un_char = un_char;
1921 un_char = (unsigned char)*s;
1926 weight -= seen[un_char] * 10;
1927 if (isALNUM_lazy_if(s+1,UTF)) {
1928 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1929 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1934 else if (*s == '$' && s[1] &&
1935 strchr("[#!%*<>()-=",s[1])) {
1936 if (/*{*/ strchr("])} =",s[2]))
1945 if (strchr("wds]",s[1]))
1947 else if (seen['\''] || seen['"'])
1949 else if (strchr("rnftbxcav",s[1]))
1951 else if (isDIGIT(s[1])) {
1953 while (s[1] && isDIGIT(s[1]))
1963 if (strchr("aA01! ",last_un_char))
1965 if (strchr("zZ79~",s[1]))
1967 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1968 weight -= 5; /* cope with negative subscript */
1971 if (!isALNUM(last_un_char)
1972 && !(last_un_char == '$' || last_un_char == '@'
1973 || last_un_char == '&')
1974 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
1979 if (keyword(tmpbuf, d - tmpbuf))
1982 if (un_char == last_un_char + 1)
1984 weight -= seen[un_char];
1989 if (weight >= 0) /* probably a character class */
1999 * Does all the checking to disambiguate
2001 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2002 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2004 * First argument is the stuff after the first token, e.g. "bar".
2006 * Not a method if bar is a filehandle.
2007 * Not a method if foo is a subroutine prototyped to take a filehandle.
2008 * Not a method if it's really "Foo $bar"
2009 * Method if it's "foo $bar"
2010 * Not a method if it's really "print foo $bar"
2011 * Method if it's really "foo package::" (interpreted as package->foo)
2012 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2013 * Not a method if bar is a filehandle or package, but is quoted with
2018 S_intuit_method(pTHX_ char *start, GV *gv)
2020 char *s = start + (*start == '$');
2021 char tmpbuf[sizeof PL_tokenbuf];
2029 if ((cv = GvCVu(gv))) {
2030 char *proto = SvPVX(cv);
2040 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2041 /* start is the beginning of the possible filehandle/object,
2042 * and s is the end of it
2043 * tmpbuf is a copy of it
2046 if (*start == '$') {
2047 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2052 return *s == '(' ? FUNCMETH : METHOD;
2054 if (!keyword(tmpbuf, len)) {
2055 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2060 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2061 if (indirgv && GvCVu(indirgv))
2063 /* filehandle or package name makes it a method */
2064 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2066 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2067 return 0; /* no assumptions -- "=>" quotes bearword */
2069 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
2070 newSVpvn(tmpbuf,len));
2071 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
2075 return *s == '(' ? FUNCMETH : METHOD;
2083 * Return a string of Perl code to load the debugger. If PERL5DB
2084 * is set, it will return the contents of that, otherwise a
2085 * compile-time require of perl5db.pl.
2092 char *pdb = PerlEnv_getenv("PERL5DB");
2096 SETERRNO(0,SS_NORMAL);
2097 return "BEGIN { require 'perl5db.pl' }";
2103 /* Encoded script support. filter_add() effectively inserts a
2104 * 'pre-processing' function into the current source input stream.
2105 * Note that the filter function only applies to the current source file
2106 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2108 * The datasv parameter (which may be NULL) can be used to pass
2109 * private data to this instance of the filter. The filter function
2110 * can recover the SV using the FILTER_DATA macro and use it to
2111 * store private buffers and state information.
2113 * The supplied datasv parameter is upgraded to a PVIO type
2114 * and the IoDIRP/IoANY field is used to store the function pointer,
2115 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2116 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2117 * private use must be set using malloc'd pointers.
2121 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2126 if (!PL_rsfp_filters)
2127 PL_rsfp_filters = newAV();
2129 datasv = NEWSV(255,0);
2130 if (!SvUPGRADE(datasv, SVt_PVIO))
2131 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
2132 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
2133 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2134 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2135 (void*)funcp, SvPV_nolen(datasv)));
2136 av_unshift(PL_rsfp_filters, 1);
2137 av_store(PL_rsfp_filters, 0, datasv) ;
2142 /* Delete most recently added instance of this filter function. */
2144 Perl_filter_del(pTHX_ filter_t funcp)
2147 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2148 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2150 /* if filter is on top of stack (usual case) just pop it off */
2151 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2152 if (IoANY(datasv) == (void *)funcp) {
2153 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2154 IoANY(datasv) = (void *)NULL;
2155 sv_free(av_pop(PL_rsfp_filters));
2159 /* we need to search for the correct entry and clear it */
2160 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2164 /* Invoke the idxth filter function for the current rsfp. */
2165 /* maxlen 0 = read one text line */
2167 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2172 if (!PL_rsfp_filters)
2174 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2175 /* Provide a default input filter to make life easy. */
2176 /* Note that we append to the line. This is handy. */
2177 DEBUG_P(PerlIO_printf(Perl_debug_log,
2178 "filter_read %d: from rsfp\n", idx));
2182 int old_len = SvCUR(buf_sv) ;
2184 /* ensure buf_sv is large enough */
2185 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2186 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2187 if (PerlIO_error(PL_rsfp))
2188 return -1; /* error */
2190 return 0 ; /* end of file */
2192 SvCUR_set(buf_sv, old_len + len) ;
2195 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2196 if (PerlIO_error(PL_rsfp))
2197 return -1; /* error */
2199 return 0 ; /* end of file */
2202 return SvCUR(buf_sv);
2204 /* Skip this filter slot if filter has been deleted */
2205 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2206 DEBUG_P(PerlIO_printf(Perl_debug_log,
2207 "filter_read %d: skipped (filter deleted)\n",
2209 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2211 /* Get function pointer hidden within datasv */
2212 funcp = (filter_t)IoANY(datasv);
2213 DEBUG_P(PerlIO_printf(Perl_debug_log,
2214 "filter_read %d: via function %p (%s)\n",
2215 idx, (void*)funcp, SvPV_nolen(datasv)));
2216 /* Call function. The function is expected to */
2217 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2218 /* Return: <0:error, =0:eof, >0:not eof */
2219 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2223 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2225 #ifdef PERL_CR_FILTER
2226 if (!PL_rsfp_filters) {
2227 filter_add(S_cr_textfilter,NULL);
2230 if (PL_rsfp_filters) {
2232 SvCUR_set(sv, 0); /* start with empty line */
2233 if (FILTER_READ(0, sv, 0) > 0)
2234 return ( SvPVX(sv) ) ;
2239 return (sv_gets(sv, fp, append));
2243 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2247 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2251 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2252 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2254 return GvHV(gv); /* Foo:: */
2257 /* use constant CLASS => 'MyClass' */
2258 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2260 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2261 pkgname = SvPV_nolen(sv);
2265 return gv_stashpv(pkgname, FALSE);
2269 static char* exp_name[] =
2270 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2271 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2278 Works out what to call the token just pulled out of the input
2279 stream. The yacc parser takes care of taking the ops we return and
2280 stitching them into a tree.
2286 if read an identifier
2287 if we're in a my declaration
2288 croak if they tried to say my($foo::bar)
2289 build the ops for a my() declaration
2290 if it's an access to a my() variable
2291 are we in a sort block?
2292 croak if my($a); $a <=> $b
2293 build ops for access to a my() variable
2294 if in a dq string, and they've said @foo and we can't find @foo
2296 build ops for a bareword
2297 if we already built the token before, use it.
2302 #pragma segment Perl_yylex
2307 register char *s = PL_bufptr;
2314 I32 orig_keyword = 0;
2317 PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
2318 lex_state_names[PL_lex_state]);
2320 /* check if there's an identifier for us to look at */
2321 if (PL_pending_ident)
2322 return REPORT(S_pending_ident(aTHX));
2324 /* no identifier pending identification */
2326 switch (PL_lex_state) {
2328 case LEX_NORMAL: /* Some compilers will produce faster */
2329 case LEX_INTERPNORMAL: /* code if we comment these out. */
2333 /* when we've already built the next token, just pull it out of the queue */
2336 yylval = PL_nextval[PL_nexttoke];
2338 PL_lex_state = PL_lex_defer;
2339 PL_expect = PL_lex_expect;
2340 PL_lex_defer = LEX_NORMAL;
2342 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2343 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2344 (IV)PL_nexttype[PL_nexttoke]); });
2346 return REPORT(PL_nexttype[PL_nexttoke]);
2348 /* interpolated case modifiers like \L \U, including \Q and \E.
2349 when we get here, PL_bufptr is at the \
2351 case LEX_INTERPCASEMOD:
2353 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2354 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2356 /* handle \E or end of string */
2357 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2361 if (PL_lex_casemods) {
2362 oldmod = PL_lex_casestack[--PL_lex_casemods];
2363 PL_lex_casestack[PL_lex_casemods] = '\0';
2365 if (PL_bufptr != PL_bufend
2366 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2368 PL_lex_state = LEX_INTERPCONCAT;
2372 if (PL_bufptr != PL_bufend)
2374 PL_lex_state = LEX_INTERPCONCAT;
2378 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2379 "### Saw case modifier at '%s'\n", PL_bufptr); });
2381 if (s[1] == '\\' && s[2] == 'E') {
2383 PL_lex_state = LEX_INTERPCONCAT;
2387 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2388 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2389 if ((*s == 'L' || *s == 'U') &&
2390 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2391 PL_lex_casestack[--PL_lex_casemods] = '\0';
2394 if (PL_lex_casemods > 10)
2395 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2396 PL_lex_casestack[PL_lex_casemods++] = *s;
2397 PL_lex_casestack[PL_lex_casemods] = '\0';
2398 PL_lex_state = LEX_INTERPCONCAT;
2399 PL_nextval[PL_nexttoke].ival = 0;
2402 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2404 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2406 PL_nextval[PL_nexttoke].ival = OP_LC;
2408 PL_nextval[PL_nexttoke].ival = OP_UC;
2410 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2412 Perl_croak(aTHX_ "panic: yylex");
2416 if (PL_lex_starts) {
2419 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2420 if (PL_lex_casemods == 1 && PL_lex_inpat)
2429 case LEX_INTERPPUSH:
2430 return REPORT(sublex_push());
2432 case LEX_INTERPSTART:
2433 if (PL_bufptr == PL_bufend)
2434 return REPORT(sublex_done());
2435 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2436 "### Interpolated variable at '%s'\n", PL_bufptr); });
2438 PL_lex_dojoin = (*PL_bufptr == '@');
2439 PL_lex_state = LEX_INTERPNORMAL;
2440 if (PL_lex_dojoin) {
2441 PL_nextval[PL_nexttoke].ival = 0;
2443 force_ident("\"", '$');
2444 PL_nextval[PL_nexttoke].ival = 0;
2446 PL_nextval[PL_nexttoke].ival = 0;
2448 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2451 if (PL_lex_starts++) {
2453 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2454 if (!PL_lex_casemods && PL_lex_inpat)
2461 case LEX_INTERPENDMAYBE:
2462 if (intuit_more(PL_bufptr)) {
2463 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2469 if (PL_lex_dojoin) {
2470 PL_lex_dojoin = FALSE;
2471 PL_lex_state = LEX_INTERPCONCAT;
2474 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2475 && SvEVALED(PL_lex_repl))
2477 if (PL_bufptr != PL_bufend)
2478 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2479 PL_lex_repl = Nullsv;
2482 case LEX_INTERPCONCAT:
2484 if (PL_lex_brackets)
2485 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2487 if (PL_bufptr == PL_bufend)
2488 return REPORT(sublex_done());
2490 if (SvIVX(PL_linestr) == '\'') {
2491 SV *sv = newSVsv(PL_linestr);
2494 else if ( PL_hints & HINT_NEW_RE )
2495 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2496 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2500 s = scan_const(PL_bufptr);
2502 PL_lex_state = LEX_INTERPCASEMOD;
2504 PL_lex_state = LEX_INTERPSTART;
2507 if (s != PL_bufptr) {
2508 PL_nextval[PL_nexttoke] = yylval;
2511 if (PL_lex_starts++) {
2512 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2513 if (!PL_lex_casemods && PL_lex_inpat)
2526 PL_lex_state = LEX_NORMAL;
2527 s = scan_formline(PL_bufptr);
2528 if (!PL_lex_formbrack)
2534 PL_oldoldbufptr = PL_oldbufptr;
2537 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
2538 exp_name[PL_expect], s);
2544 if (isIDFIRST_lazy_if(s,UTF))
2546 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2549 goto fake_eof; /* emulate EOF on ^D or ^Z */
2554 if (PL_lex_brackets) {
2555 if (PL_lex_formbrack)
2556 yyerror("Format not terminated");
2558 yyerror("Missing right curly or square bracket");
2560 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2561 "### Tokener got EOF\n");
2565 if (s++ < PL_bufend)
2566 goto retry; /* ignore stray nulls */
2569 if (!PL_in_eval && !PL_preambled) {
2570 PL_preambled = TRUE;
2571 sv_setpv(PL_linestr,incl_perldb());
2572 if (SvCUR(PL_linestr))
2573 sv_catpvn(PL_linestr,";", 1);
2575 while(AvFILLp(PL_preambleav) >= 0) {
2576 SV *tmpsv = av_shift(PL_preambleav);
2577 sv_catsv(PL_linestr, tmpsv);
2578 sv_catpvn(PL_linestr, ";", 1);
2581 sv_free((SV*)PL_preambleav);
2582 PL_preambleav = NULL;
2584 if (PL_minus_n || PL_minus_p) {
2585 sv_catpv(PL_linestr, "LINE: while (<>) {");
2587 sv_catpv(PL_linestr,"chomp;");
2590 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2591 || *PL_splitstr == '"')
2592 && strchr(PL_splitstr + 1, *PL_splitstr))
2593 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2595 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2596 bytes can be used as quoting characters. :-) */
2597 /* The count here deliberately includes the NUL
2598 that terminates the C string constant. This
2599 embeds the opening NUL into the string. */
2600 Perl_sv_catpvn(aTHX_ PL_linestr,
2601 "our @F=split(q", 15);
2606 sv_catpvn(PL_linestr, s, 1);
2607 sv_catpvn(PL_linestr, s, 1);
2609 /* This loop will embed the trailing NUL of
2610 PL_linestr as the last thing it does before
2612 Perl_sv_catpvn(aTHX_ PL_linestr, ");", 2);
2616 sv_catpv(PL_linestr,"our @F=split(' ');");
2619 sv_catpvn(PL_linestr, "\n", 1);
2620 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2621 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2622 PL_last_lop = PL_last_uni = Nullch;
2623 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2624 SV *sv = NEWSV(85,0);
2626 sv_upgrade(sv, SVt_PVMG);
2627 sv_setsv(sv,PL_linestr);
2630 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2635 bof = PL_rsfp ? TRUE : FALSE;
2636 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2639 if (PL_preprocess && !PL_in_eval)
2640 (void)PerlProc_pclose(PL_rsfp);
2641 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2642 PerlIO_clearerr(PL_rsfp);
2644 (void)PerlIO_close(PL_rsfp);
2646 PL_doextract = FALSE;
2648 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2649 sv_setpv(PL_linestr,PL_minus_p
2650 ? ";}continue{print;}" : ";}");
2651 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2652 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2653 PL_last_lop = PL_last_uni = Nullch;
2654 PL_minus_n = PL_minus_p = 0;
2657 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2658 PL_last_lop = PL_last_uni = Nullch;
2659 sv_setpv(PL_linestr,"");
2660 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2662 /* If it looks like the start of a BOM or raw UTF-16,
2663 * check if it in fact is. */
2669 #ifdef PERLIO_IS_STDIO
2670 # ifdef __GNU_LIBRARY__
2671 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2672 # define FTELL_FOR_PIPE_IS_BROKEN
2676 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2677 # define FTELL_FOR_PIPE_IS_BROKEN
2682 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2683 /* This loses the possibility to detect the bof
2684 * situation on perl -P when the libc5 is being used.
2685 * Workaround? Maybe attach some extra state to PL_rsfp?
2688 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2690 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2693 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2694 s = swallow_bom((U8*)s);
2698 /* Incest with pod. */
2699 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2700 sv_setpv(PL_linestr, "");
2701 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2702 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2703 PL_last_lop = PL_last_uni = Nullch;
2704 PL_doextract = FALSE;
2708 } while (PL_doextract);
2709 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2710 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2711 SV *sv = NEWSV(85,0);
2713 sv_upgrade(sv, SVt_PVMG);
2714 sv_setsv(sv,PL_linestr);
2717 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2719 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2720 PL_last_lop = PL_last_uni = Nullch;
2721 if (CopLINE(PL_curcop) == 1) {
2722 while (s < PL_bufend && isSPACE(*s))
2724 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2728 if (*s == '#' && *(s+1) == '!')
2730 #ifdef ALTERNATE_SHEBANG
2732 static char as[] = ALTERNATE_SHEBANG;
2733 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2734 d = s + (sizeof(as) - 1);
2736 #endif /* ALTERNATE_SHEBANG */
2745 while (*d && !isSPACE(*d))
2749 #ifdef ARG_ZERO_IS_SCRIPT
2750 if (ipathend > ipath) {
2752 * HP-UX (at least) sets argv[0] to the script name,
2753 * which makes $^X incorrect. And Digital UNIX and Linux,
2754 * at least, set argv[0] to the basename of the Perl
2755 * interpreter. So, having found "#!", we'll set it right.
2757 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2758 assert(SvPOK(x) || SvGMAGICAL(x));
2759 if (sv_eq(x, CopFILESV(PL_curcop))) {
2760 sv_setpvn(x, ipath, ipathend - ipath);
2766 char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2767 char *lstart = SvPV(x,llen);
2769 bstart += blen - llen;
2770 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2771 sv_setpvn(x, ipath, ipathend - ipath);
2776 TAINT_NOT; /* $^X is always tainted, but that's OK */
2778 #endif /* ARG_ZERO_IS_SCRIPT */
2783 d = instr(s,"perl -");
2785 d = instr(s,"perl");
2787 /* avoid getting into infinite loops when shebang
2788 * line contains "Perl" rather than "perl" */
2790 for (d = ipathend-4; d >= ipath; --d) {
2791 if ((*d == 'p' || *d == 'P')
2792 && !ibcmp(d, "perl", 4))
2802 #ifdef ALTERNATE_SHEBANG
2804 * If the ALTERNATE_SHEBANG on this system starts with a
2805 * character that can be part of a Perl expression, then if
2806 * we see it but not "perl", we're probably looking at the
2807 * start of Perl code, not a request to hand off to some
2808 * other interpreter. Similarly, if "perl" is there, but
2809 * not in the first 'word' of the line, we assume the line
2810 * contains the start of the Perl program.
2812 if (d && *s != '#') {
2814 while (*c && !strchr("; \t\r\n\f\v#", *c))
2817 d = Nullch; /* "perl" not in first word; ignore */
2819 *s = '#'; /* Don't try to parse shebang line */
2821 #endif /* ALTERNATE_SHEBANG */
2822 #ifndef MACOS_TRADITIONAL
2827 !instr(s,"indir") &&
2828 instr(PL_origargv[0],"perl"))
2834 while (s < PL_bufend && isSPACE(*s))
2836 if (s < PL_bufend) {
2837 Newz(899,newargv,PL_origargc+3,char*);
2839 while (s < PL_bufend && !isSPACE(*s))
2842 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2845 newargv = PL_origargv;
2848 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2850 Perl_croak(aTHX_ "Can't exec %s", ipath);
2854 U32 oldpdb = PL_perldb;
2855 bool oldn = PL_minus_n;
2856 bool oldp = PL_minus_p;
2858 while (*d && !isSPACE(*d)) d++;
2859 while (SPACE_OR_TAB(*d)) d++;
2862 bool switches_done = PL_doswitches;
2864 if (*d == 'M' || *d == 'm') {
2866 while (*d && !isSPACE(*d)) d++;
2867 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2870 d = moreswitches(d);
2872 if (PL_doswitches && !switches_done) {
2873 int argc = PL_origargc;
2874 char **argv = PL_origargv;
2877 } while (argc && argv[0][0] == '-' && argv[0][1]);
2878 init_argv_symbols(argc,argv);
2880 if ((PERLDB_LINE && !oldpdb) ||
2881 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2882 /* if we have already added "LINE: while (<>) {",
2883 we must not do it again */
2885 sv_setpv(PL_linestr, "");
2886 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2887 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2888 PL_last_lop = PL_last_uni = Nullch;
2889 PL_preambled = FALSE;
2891 (void)gv_fetchfile(PL_origfilename);
2894 if (PL_doswitches && !switches_done) {
2895 int argc = PL_origargc;
2896 char **argv = PL_origargv;
2899 } while (argc && argv[0][0] == '-' && argv[0][1]);
2900 init_argv_symbols(argc,argv);
2906 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2908 PL_lex_state = LEX_FORMLINE;
2913 #ifdef PERL_STRICT_CR
2914 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2916 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2918 case ' ': case '\t': case '\f': case 013:
2919 #ifdef MACOS_TRADITIONAL
2926 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2927 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2928 /* handle eval qq[#line 1 "foo"\n ...] */
2929 CopLINE_dec(PL_curcop);
2933 while (s < d && *s != '\n')
2937 else if (s > d) /* Found by Ilya: feed random input to Perl. */
2938 Perl_croak(aTHX_ "panic: input overflow");
2940 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2942 PL_lex_state = LEX_FORMLINE;
2952 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2959 while (s < PL_bufend && SPACE_OR_TAB(*s))
2962 if (strnEQ(s,"=>",2)) {
2963 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2964 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2965 "### Saw unary minus before =>, forcing word '%s'\n", s);
2967 OPERATOR('-'); /* unary minus */
2969 PL_last_uni = PL_oldbufptr;
2971 case 'r': ftst = OP_FTEREAD; break;
2972 case 'w': ftst = OP_FTEWRITE; break;
2973 case 'x': ftst = OP_FTEEXEC; break;
2974 case 'o': ftst = OP_FTEOWNED; break;
2975 case 'R': ftst = OP_FTRREAD; break;
2976 case 'W': ftst = OP_FTRWRITE; break;
2977 case 'X': ftst = OP_FTREXEC; break;
2978 case 'O': ftst = OP_FTROWNED; break;
2979 case 'e': ftst = OP_FTIS; break;
2980 case 'z': ftst = OP_FTZERO; break;
2981 case 's': ftst = OP_FTSIZE; break;
2982 case 'f': ftst = OP_FTFILE; break;
2983 case 'd': ftst = OP_FTDIR; break;
2984 case 'l': ftst = OP_FTLINK; break;
2985 case 'p': ftst = OP_FTPIPE; break;
2986 case 'S': ftst = OP_FTSOCK; break;
2987 case 'u': ftst = OP_FTSUID; break;
2988 case 'g': ftst = OP_FTSGID; break;
2989 case 'k': ftst = OP_FTSVTX; break;
2990 case 'b': ftst = OP_FTBLK; break;
2991 case 'c': ftst = OP_FTCHR; break;
2992 case 't': ftst = OP_FTTTY; break;
2993 case 'T': ftst = OP_FTTEXT; break;
2994 case 'B': ftst = OP_FTBINARY; break;
2995 case 'M': case 'A': case 'C':
2996 gv_fetchpv("\024",TRUE, SVt_PV);
2998 case 'M': ftst = OP_FTMTIME; break;
2999 case 'A': ftst = OP_FTATIME; break;
3000 case 'C': ftst = OP_FTCTIME; break;
3008 PL_last_lop_op = (OPCODE)ftst;
3009 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3010 "### Saw file test %c\n", (int)ftst);
3015 /* Assume it was a minus followed by a one-letter named
3016 * subroutine call (or a -bareword), then. */
3017 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3018 "### '-%c' looked like a file test but was not\n",
3027 if (PL_expect == XOPERATOR)
3032 else if (*s == '>') {
3035 if (isIDFIRST_lazy_if(s,UTF)) {
3036 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3044 if (PL_expect == XOPERATOR)
3047 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3049 OPERATOR('-'); /* unary minus */
3056 if (PL_expect == XOPERATOR)
3061 if (PL_expect == XOPERATOR)
3064 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3070 if (PL_expect != XOPERATOR) {
3071 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3072 PL_expect = XOPERATOR;
3073 force_ident(PL_tokenbuf, '*');
3086 if (PL_expect == XOPERATOR) {
3090 PL_tokenbuf[0] = '%';
3091 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3092 if (!PL_tokenbuf[1]) {
3095 PL_pending_ident = '%';
3114 switch (PL_expect) {
3117 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3119 PL_bufptr = s; /* update in case we back off */
3125 PL_expect = XTERMBLOCK;
3129 while (isIDFIRST_lazy_if(s,UTF)) {
3130 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3131 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3132 if (tmp < 0) tmp = -tmp;
3148 d = scan_str(d,TRUE,TRUE);
3150 /* MUST advance bufptr here to avoid bogus
3151 "at end of line" context messages from yyerror().
3153 PL_bufptr = s + len;
3154 yyerror("Unterminated attribute parameter in attribute list");
3157 return REPORT(0); /* EOF indicator */
3161 SV *sv = newSVpvn(s, len);
3162 sv_catsv(sv, PL_lex_stuff);
3163 attrs = append_elem(OP_LIST, attrs,
3164 newSVOP(OP_CONST, 0, sv));
3165 SvREFCNT_dec(PL_lex_stuff);
3166 PL_lex_stuff = Nullsv;
3169 if (len == 6 && strnEQ(s, "unique", len)) {
3170 if (PL_in_my == KEY_our)
3172 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3174 ; /* skip to avoid loading attributes.pm */
3177 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3180 /* NOTE: any CV attrs applied here need to be part of
3181 the CVf_BUILTIN_ATTRS define in cv.h! */
3182 else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3183 CvLVALUE_on(PL_compcv);
3184 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3185 CvLOCKED_on(PL_compcv);
3186 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3187 CvMETHOD_on(PL_compcv);
3188 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3189 CvASSERTION_on(PL_compcv);
3190 /* After we've set the flags, it could be argued that
3191 we don't need to do the attributes.pm-based setting
3192 process, and shouldn't bother appending recognized
3193 flags. To experiment with that, uncomment the
3194 following "else". (Note that's already been
3195 uncommented. That keeps the above-applied built-in
3196 attributes from being intercepted (and possibly
3197 rejected) by a package's attribute routines, but is
3198 justified by the performance win for the common case
3199 of applying only built-in attributes.) */
3201 attrs = append_elem(OP_LIST, attrs,
3202 newSVOP(OP_CONST, 0,
3206 if (*s == ':' && s[1] != ':')
3209 break; /* require real whitespace or :'s */
3211 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3212 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3213 char q = ((*s == '\'') ? '"' : '\'');
3214 /* If here for an expression, and parsed no attrs, back off. */
3215 if (tmp == '=' && !attrs) {
3219 /* MUST advance bufptr here to avoid bogus "at end of line"
3220 context messages from yyerror().
3224 yyerror("Unterminated attribute list");
3226 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3234 PL_nextval[PL_nexttoke].opval = attrs;
3242 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3243 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3260 if (PL_lex_brackets <= 0)
3261 yyerror("Unmatched right square bracket");
3264 if (PL_lex_state == LEX_INTERPNORMAL) {
3265 if (PL_lex_brackets == 0) {
3266 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3267 PL_lex_state = LEX_INTERPEND;
3274 if (PL_lex_brackets > 100) {
3275 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3277 switch (PL_expect) {
3279 if (PL_lex_formbrack) {
3283 if (PL_oldoldbufptr == PL_last_lop)
3284 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3286 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3287 OPERATOR(HASHBRACK);
3289 while (s < PL_bufend && SPACE_OR_TAB(*s))
3292 PL_tokenbuf[0] = '\0';
3293 if (d < PL_bufend && *d == '-') {
3294 PL_tokenbuf[0] = '-';
3296 while (d < PL_bufend && SPACE_OR_TAB(*d))
3299 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3300 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3302 while (d < PL_bufend && SPACE_OR_TAB(*d))
3305 char minus = (PL_tokenbuf[0] == '-');
3306 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3314 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3319 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3324 if (PL_oldoldbufptr == PL_last_lop)
3325 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3327 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3330 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3332 /* This hack is to get the ${} in the message. */
3334 yyerror("syntax error");
3337 OPERATOR(HASHBRACK);
3339 /* This hack serves to disambiguate a pair of curlies
3340 * as being a block or an anon hash. Normally, expectation
3341 * determines that, but in cases where we're not in a
3342 * position to expect anything in particular (like inside
3343 * eval"") we have to resolve the ambiguity. This code
3344 * covers the case where the first term in the curlies is a
3345 * quoted string. Most other cases need to be explicitly
3346 * disambiguated by prepending a `+' before the opening
3347 * curly in order to force resolution as an anon hash.
3349 * XXX should probably propagate the outer expectation
3350 * into eval"" to rely less on this hack, but that could
3351 * potentially break current behavior of eval"".
3355 if (*s == '\'' || *s == '"' || *s == '`') {
3356 /* common case: get past first string, handling escapes */
3357 for (t++; t < PL_bufend && *t != *s;)
3358 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3362 else if (*s == 'q') {
3365 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3368 /* skip q//-like construct */
3370 char open, close, term;
3373 while (t < PL_bufend && isSPACE(*t))
3375 /* check for q => */
3376 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3377 OPERATOR(HASHBRACK);
3381 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3385 for (t++; t < PL_bufend; t++) {
3386 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3388 else if (*t == open)
3392 for (t++; t < PL_bufend; t++) {
3393 if (*t == '\\' && t+1 < PL_bufend)
3395 else if (*t == close && --brackets <= 0)
3397 else if (*t == open)
3404 /* skip plain q word */
3405 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3408 else if (isALNUM_lazy_if(t,UTF)) {
3410 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3413 while (t < PL_bufend && isSPACE(*t))
3415 /* if comma follows first term, call it an anon hash */
3416 /* XXX it could be a comma expression with loop modifiers */
3417 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3418 || (*t == '=' && t[1] == '>')))
3419 OPERATOR(HASHBRACK);
3420 if (PL_expect == XREF)
3423 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3429 yylval.ival = CopLINE(PL_curcop);
3430 if (isSPACE(*s) || *s == '#')
3431 PL_copline = NOLINE; /* invalidate current command line number */
3436 if (PL_lex_brackets <= 0)
3437 yyerror("Unmatched right curly bracket");
3439 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3440 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3441 PL_lex_formbrack = 0;
3442 if (PL_lex_state == LEX_INTERPNORMAL) {
3443 if (PL_lex_brackets == 0) {
3444 if (PL_expect & XFAKEBRACK) {
3445 PL_expect &= XENUMMASK;
3446 PL_lex_state = LEX_INTERPEND;
3448 return yylex(); /* ignore fake brackets */
3450 if (*s == '-' && s[1] == '>')
3451 PL_lex_state = LEX_INTERPENDMAYBE;
3452 else if (*s != '[' && *s != '{')
3453 PL_lex_state = LEX_INTERPEND;
3456 if (PL_expect & XFAKEBRACK) {
3457 PL_expect &= XENUMMASK;
3459 return yylex(); /* ignore fake brackets */
3469 if (PL_expect == XOPERATOR) {
3470 if (ckWARN(WARN_SEMICOLON)
3471 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3473 CopLINE_dec(PL_curcop);
3474 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3475 CopLINE_inc(PL_curcop);
3480 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3482 PL_expect = XOPERATOR;
3483 force_ident(PL_tokenbuf, '&');
3487 yylval.ival = (OPpENTERSUB_AMPER<<8);
3506 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3507 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3509 if (PL_expect == XSTATE && isALPHA(tmp) &&
3510 (s == PL_linestart+1 || s[-2] == '\n') )
3512 if (PL_in_eval && !PL_rsfp) {
3517 if (strnEQ(s,"=cut",4)) {
3531 PL_doextract = TRUE;
3534 if (PL_lex_brackets < PL_lex_formbrack) {
3536 #ifdef PERL_STRICT_CR
3537 for (t = s; SPACE_OR_TAB(*t); t++) ;
3539 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3541 if (*t == '\n' || *t == '#') {
3553 /* was this !=~ where !~ was meant?
3554 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3556 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3559 while (t < PL_bufend && isSPACE(*t))
3562 if (*t == '/' || *t == '?' ||
3563 ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3564 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3565 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3566 "!=~ should be !~");
3575 if (PL_expect != XOPERATOR) {
3576 if (s[1] != '<' && !strchr(s,'>'))
3579 s = scan_heredoc(s);
3581 s = scan_inputsymbol(s);
3582 TERM(sublex_start());
3587 SHop(OP_LEFT_SHIFT);
3601 SHop(OP_RIGHT_SHIFT);
3610 if (PL_expect == XOPERATOR) {
3611 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3614 return REPORT(','); /* grandfather non-comma-format format */
3618 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3619 PL_tokenbuf[0] = '@';
3620 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3621 sizeof PL_tokenbuf - 1, FALSE);
3622 if (PL_expect == XOPERATOR)
3623 no_op("Array length", s);
3624 if (!PL_tokenbuf[1])
3626 PL_expect = XOPERATOR;
3627 PL_pending_ident = '#';
3631 PL_tokenbuf[0] = '$';
3632 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3633 sizeof PL_tokenbuf - 1, FALSE);
3634 if (PL_expect == XOPERATOR)
3636 if (!PL_tokenbuf[1]) {
3638 yyerror("Final $ should be \\$ or $name");
3642 /* This kludge not intended to be bulletproof. */
3643 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3644 yylval.opval = newSVOP(OP_CONST, 0,
3645 newSViv(PL_compiling.cop_arybase));
3646 yylval.opval->op_private = OPpCONST_ARYBASE;
3652 if (PL_lex_state == LEX_NORMAL)
3655 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3658 PL_tokenbuf[0] = '@';
3659 if (ckWARN(WARN_SYNTAX)) {
3661 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3664 PL_bufptr = skipspace(PL_bufptr);
3665 while (t < PL_bufend && *t != ']')
3667 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3668 "Multidimensional syntax %.*s not supported",
3669 (t - PL_bufptr) + 1, PL_bufptr);
3673 else if (*s == '{') {
3674 PL_tokenbuf[0] = '%';
3675 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3676 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3678 char tmpbuf[sizeof PL_tokenbuf];
3680 for (t++; isSPACE(*t); t++) ;
3681 if (isIDFIRST_lazy_if(t,UTF)) {
3682 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3683 for (; isSPACE(*t); t++) ;
3684 if (*t == ';' && get_cv(tmpbuf, FALSE))
3685 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3686 "You need to quote \"%s\"", tmpbuf);
3692 PL_expect = XOPERATOR;
3693 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3694 bool islop = (PL_last_lop == PL_oldoldbufptr);
3695 if (!islop || PL_last_lop_op == OP_GREPSTART)
3696 PL_expect = XOPERATOR;
3697 else if (strchr("$@\"'`q", *s))
3698 PL_expect = XTERM; /* e.g. print $fh "foo" */
3699 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3700 PL_expect = XTERM; /* e.g. print $fh &sub */
3701 else if (isIDFIRST_lazy_if(s,UTF)) {
3702 char tmpbuf[sizeof PL_tokenbuf];
3703 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3704 if ((tmp = keyword(tmpbuf, len))) {
3705 /* binary operators exclude handle interpretations */
3717 PL_expect = XTERM; /* e.g. print $fh length() */
3722 PL_expect = XTERM; /* e.g. print $fh subr() */
3725 else if (isDIGIT(*s))
3726 PL_expect = XTERM; /* e.g. print $fh 3 */
3727 else if (*s == '.' && isDIGIT(s[1]))
3728 PL_expect = XTERM; /* e.g. print $fh .3 */
3729 else if ((*s == '?' || *s == '-' || *s == '+')
3730 && !isSPACE(s[1]) && s[1] != '=')
3731 PL_expect = XTERM; /* e.g. print $fh -1 */
3732 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3733 PL_expect = XTERM; /* e.g. print $fh /.../
3734 XXX except DORDOR operator */
3735 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3736 PL_expect = XTERM; /* print $fh <<"EOF" */
3738 PL_pending_ident = '$';
3742 if (PL_expect == XOPERATOR)
3744 PL_tokenbuf[0] = '@';
3745 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3746 if (!PL_tokenbuf[1]) {
3749 if (PL_lex_state == LEX_NORMAL)
3751 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3753 PL_tokenbuf[0] = '%';
3755 /* Warn about @ where they meant $. */
3756 if (ckWARN(WARN_SYNTAX)) {
3757 if (*s == '[' || *s == '{') {
3759 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3761 if (*t == '}' || *t == ']') {
3763 PL_bufptr = skipspace(PL_bufptr);
3764 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3765 "Scalar value %.*s better written as $%.*s",
3766 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3771 PL_pending_ident = '@';
3774 case '/': /* may be division, defined-or, or pattern */
3775 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3779 case '?': /* may either be conditional or pattern */
3780 if(PL_expect == XOPERATOR) {
3788 /* A // operator. */
3798 /* Disable warning on "study /blah/" */
3799 if (PL_oldoldbufptr == PL_last_uni
3800 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3801 || memNE(PL_last_uni, "study", 5)
3802 || isALNUM_lazy_if(PL_last_uni+5,UTF)
3805 s = scan_pat(s,OP_MATCH);
3806 TERM(sublex_start());
3810 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3811 #ifdef PERL_STRICT_CR
3814 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3816 && (s == PL_linestart || s[-1] == '\n') )
3818 PL_lex_formbrack = 0;
3822 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3828 yylval.ival = OPf_SPECIAL;
3834 if (PL_expect != XOPERATOR)
3839 case '0': case '1': case '2': case '3': case '4':
3840 case '5': case '6': case '7': case '8': case '9':
3841 s = scan_num(s, &yylval);
3842 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3843 "### Saw number in '%s'\n", s);
3845 if (PL_expect == XOPERATOR)
3850 s = scan_str(s,FALSE,FALSE);
3851 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3852 "### Saw string before '%s'\n", s);
3854 if (PL_expect == XOPERATOR) {
3855 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3858 return REPORT(','); /* grandfather non-comma-format format */
3864 missingterm((char*)0);
3865 yylval.ival = OP_CONST;
3866 TERM(sublex_start());
3869 s = scan_str(s,FALSE,FALSE);
3870 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3871 "### Saw string before '%s'\n", s);
3873 if (PL_expect == XOPERATOR) {
3874 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3877 return REPORT(','); /* grandfather non-comma-format format */
3883 missingterm((char*)0);
3884 yylval.ival = OP_CONST;
3885 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3886 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3887 yylval.ival = OP_STRINGIFY;
3891 TERM(sublex_start());
3894 s = scan_str(s,FALSE,FALSE);
3895 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3896 "### Saw backtick string before '%s'\n", s);
3898 if (PL_expect == XOPERATOR)
3899 no_op("Backticks",s);
3901 missingterm((char*)0);
3902 yylval.ival = OP_BACKTICK;
3904 TERM(sublex_start());
3908 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3909 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3911 if (PL_expect == XOPERATOR)
3912 no_op("Backslash",s);
3916 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3920 while (isDIGIT(*start) || *start == '_')
3922 if (*start == '.' && isDIGIT(start[1])) {
3923 s = scan_num(s, &yylval);
3926 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3927 else if (!isALPHA(*start) && (PL_expect == XTERM
3928 || PL_expect == XREF || PL_expect == XSTATE
3929 || PL_expect == XTERMORDORDOR)) {
3933 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3936 s = scan_num(s, &yylval);
3943 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3983 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3985 /* Some keywords can be followed by any delimiter, including ':' */
3986 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3987 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3988 (PL_tokenbuf[0] == 'q' &&
3989 strchr("qwxr", PL_tokenbuf[1])))));
3991 /* x::* is just a word, unless x is "CORE" */
3992 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3996 while (d < PL_bufend && isSPACE(*d))
3997 d++; /* no comments skipped here, or s### is misparsed */
3999 /* Is this a label? */
4000 if (!tmp && PL_expect == XSTATE
4001 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4003 yylval.pval = savepv(PL_tokenbuf);
4008 /* Check for keywords */
4009 tmp = keyword(PL_tokenbuf, len);
4011 /* Is this a word before a => operator? */
4012 if (*d == '=' && d[1] == '>') {
4014 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
4015 yylval.opval->op_private = OPpCONST_BARE;
4016 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4017 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4021 if (tmp < 0) { /* second-class keyword? */
4022 GV *ogv = Nullgv; /* override (winner) */
4023 GV *hgv = Nullgv; /* hidden (loser) */
4024 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4026 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4029 if (GvIMPORTED_CV(gv))
4031 else if (! CvMETHOD(cv))
4035 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4036 (gv = *gvp) != (GV*)&PL_sv_undef &&
4037 GvCVu(gv) && GvIMPORTED_CV(gv))
4044 tmp = 0; /* overridden by import or by GLOBAL */
4047 && -tmp==KEY_lock /* XXX generalizable kludge */
4049 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4051 tmp = 0; /* any sub overrides "weak" keyword */
4056 && PL_expect != XOPERATOR
4057 && PL_expect != XTERMORDORDOR)
4059 /* any sub overrides the "err" keyword, except when really an
4060 * operator is expected */
4063 else { /* no override */
4065 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4066 Perl_warner(aTHX_ packWARN(WARN_MISC),
4067 "dump() better written as CORE::dump()");
4071 if (ckWARN(WARN_AMBIGUOUS) && hgv
4072 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
4073 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4074 "Ambiguous call resolved as CORE::%s(), %s",
4075 GvENAME(hgv), "qualify as such or use &");
4082 default: /* not a keyword */
4086 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4088 /* Get the rest if it looks like a package qualifier */
4090 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4092 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4095 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4096 *s == '\'' ? "'" : "::");
4101 if (PL_expect == XOPERATOR) {
4102 if (PL_bufptr == PL_linestart) {
4103 CopLINE_dec(PL_curcop);
4104 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4105 CopLINE_inc(PL_curcop);
4108 no_op("Bareword",s);
4111 /* Look for a subroutine with this name in current package,
4112 unless name is "Foo::", in which case Foo is a bearword
4113 (and a package name). */
4116 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4118 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4119 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4120 "Bareword \"%s\" refers to nonexistent package",
4123 PL_tokenbuf[len] = '\0';
4130 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4133 /* if we saw a global override before, get the right name */
4136 sv = newSVpvn("CORE::GLOBAL::",14);
4137 sv_catpv(sv,PL_tokenbuf);
4140 sv = newSVpv(PL_tokenbuf,0);
4142 /* Presume this is going to be a bareword of some sort. */
4145 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4146 yylval.opval->op_private = OPpCONST_BARE;
4147 /* UTF-8 package name? */
4148 if (UTF && !IN_BYTES &&
4149 is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
4152 /* And if "Foo::", then that's what it certainly is. */
4157 /* See if it's the indirect object for a list operator. */
4159 if (PL_oldoldbufptr &&
4160 PL_oldoldbufptr < PL_bufptr &&
4161 (PL_oldoldbufptr == PL_last_lop
4162 || PL_oldoldbufptr == PL_last_uni) &&
4163 /* NO SKIPSPACE BEFORE HERE! */
4164 (PL_expect == XREF ||
4165 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4167 bool immediate_paren = *s == '(';
4169 /* (Now we can afford to cross potential line boundary.) */
4172 /* Two barewords in a row may indicate method call. */
4174 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4177 /* If not a declared subroutine, it's an indirect object. */
4178 /* (But it's an indir obj regardless for sort.) */
4180 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4181 ((!gv || !GvCVu(gv)) &&
4182 (PL_last_lop_op != OP_MAPSTART &&
4183 PL_last_lop_op != OP_GREPSTART))))
4185 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4190 PL_expect = XOPERATOR;
4193 /* Is this a word before a => operator? */
4194 if (*s == '=' && s[1] == '>' && !pkgname) {
4196 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4197 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4198 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4202 /* If followed by a paren, it's certainly a subroutine. */
4205 if (gv && GvCVu(gv)) {
4206 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4207 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4212 PL_nextval[PL_nexttoke].opval = yylval.opval;
4213 PL_expect = XOPERATOR;
4219 /* If followed by var or block, call it a method (unless sub) */
4221 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4222 PL_last_lop = PL_oldbufptr;
4223 PL_last_lop_op = OP_METHOD;
4227 /* If followed by a bareword, see if it looks like indir obj. */
4230 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4231 && (tmp = intuit_method(s,gv)))
4234 /* Not a method, so call it a subroutine (if defined) */
4236 if (gv && GvCVu(gv)) {
4238 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4239 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4240 "Ambiguous use of -%s resolved as -&%s()",
4241 PL_tokenbuf, PL_tokenbuf);
4242 /* Check for a constant sub */
4244 if ((sv = cv_const_sv(cv))) {
4246 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4247 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4248 yylval.opval->op_private = 0;
4252 /* Resolve to GV now. */
4253 op_free(yylval.opval);
4254 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4255 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4256 PL_last_lop = PL_oldbufptr;
4257 PL_last_lop_op = OP_ENTERSUB;
4258 /* Is there a prototype? */
4261 char *proto = SvPV((SV*)cv, len);
4264 if (*proto == '$' && proto[1] == '\0')
4266 while (*proto == ';')
4268 if (*proto == '&' && *s == '{') {
4269 sv_setpv(PL_subname, PL_curstash ?
4270 "__ANON__" : "__ANON__::__ANON__");
4274 PL_nextval[PL_nexttoke].opval = yylval.opval;
4280 /* Call it a bare word */
4282 if (PL_hints & HINT_STRICT_SUBS)
4283 yylval.opval->op_private |= OPpCONST_STRICT;
4286 if (ckWARN(WARN_RESERVED)) {
4287 if (lastchar != '-') {
4288 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4289 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4290 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4297 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4298 && ckWARN_d(WARN_AMBIGUOUS)) {
4299 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4300 "Operator or semicolon missing before %c%s",
4301 lastchar, PL_tokenbuf);
4302 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4303 "Ambiguous use of %c resolved as operator %c",
4304 lastchar, lastchar);
4310 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4311 newSVpv(CopFILE(PL_curcop),0));
4315 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4316 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4319 case KEY___PACKAGE__:
4320 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4322 ? newSVpv(HvNAME(PL_curstash), 0)
4331 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4332 char *pname = "main";
4333 if (PL_tokenbuf[2] == 'D')
4334 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4335 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4338 GvIOp(gv) = newIO();
4339 IoIFP(GvIOp(gv)) = PL_rsfp;
4340 #if defined(HAS_FCNTL) && defined(F_SETFD)
4342 int fd = PerlIO_fileno(PL_rsfp);
4343 fcntl(fd,F_SETFD,fd >= 3);
4346 /* Mark this internal pseudo-handle as clean */
4347 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4349 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4350 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4351 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4353 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4354 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4355 /* if the script was opened in binmode, we need to revert
4356 * it to text mode for compatibility; but only iff it has CRs
4357 * XXX this is a questionable hack at best. */
4358 if (PL_bufend-PL_bufptr > 2
4359 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4362 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4363 loc = PerlIO_tell(PL_rsfp);
4364 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4367 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4369 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4370 #endif /* NETWARE */
4371 #ifdef PERLIO_IS_STDIO /* really? */
4372 # if defined(__BORLANDC__)
4373 /* XXX see note in do_binmode() */
4374 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4378 PerlIO_seek(PL_rsfp, loc, 0);
4382 #ifdef PERLIO_LAYERS
4385 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4386 else if (PL_encoding) {
4393 XPUSHs(PL_encoding);
4395 call_method("name", G_SCALAR);
4399 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4400 Perl_form(aTHX_ ":encoding(%"SVf")",
4418 if (PL_expect == XSTATE) {
4425 if (*s == ':' && s[1] == ':') {
4428 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4429 if (!(tmp = keyword(PL_tokenbuf, len)))
4430 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4444 LOP(OP_ACCEPT,XTERM);
4450 LOP(OP_ATAN2,XTERM);
4456 LOP(OP_BINMODE,XTERM);
4459 LOP(OP_BLESS,XTERM);
4468 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4485 if (!PL_cryptseen) {
4486 PL_cryptseen = TRUE;
4490 LOP(OP_CRYPT,XTERM);
4493 LOP(OP_CHMOD,XTERM);
4496 LOP(OP_CHOWN,XTERM);
4499 LOP(OP_CONNECT,XTERM);
4515 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4519 PL_hints |= HINT_BLOCK_SCOPE;
4529 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4530 LOP(OP_DBMOPEN,XTERM);
4536 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4543 yylval.ival = CopLINE(PL_curcop);
4557 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4558 UNIBRACK(OP_ENTEREVAL);
4576 case KEY_endhostent:
4582 case KEY_endservent:
4585 case KEY_endprotoent:
4596 yylval.ival = CopLINE(PL_curcop);
4598 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4600 if ((PL_bufend - p) >= 3 &&
4601 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4603 else if ((PL_bufend - p) >= 4 &&
4604 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4607 if (isIDFIRST_lazy_if(p,UTF)) {
4608 p = scan_ident(p, PL_bufend,
4609 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4613 Perl_croak(aTHX_ "Missing $ on loop variable");
4618 LOP(OP_FORMLINE,XTERM);
4624 LOP(OP_FCNTL,XTERM);
4630 LOP(OP_FLOCK,XTERM);
4639 LOP(OP_GREPSTART, XREF);
4642 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4657 case KEY_getpriority:
4658 LOP(OP_GETPRIORITY,XTERM);
4660 case KEY_getprotobyname:
4663 case KEY_getprotobynumber:
4664 LOP(OP_GPBYNUMBER,XTERM);
4666 case KEY_getprotoent:
4678 case KEY_getpeername:
4679 UNI(OP_GETPEERNAME);
4681 case KEY_gethostbyname:
4684 case KEY_gethostbyaddr:
4685 LOP(OP_GHBYADDR,XTERM);
4687 case KEY_gethostent:
4690 case KEY_getnetbyname:
4693 case KEY_getnetbyaddr:
4694 LOP(OP_GNBYADDR,XTERM);
4699 case KEY_getservbyname:
4700 LOP(OP_GSBYNAME,XTERM);
4702 case KEY_getservbyport:
4703 LOP(OP_GSBYPORT,XTERM);
4705 case KEY_getservent:
4708 case KEY_getsockname:
4709 UNI(OP_GETSOCKNAME);
4711 case KEY_getsockopt:
4712 LOP(OP_GSOCKOPT,XTERM);
4734 yylval.ival = CopLINE(PL_curcop);
4738 LOP(OP_INDEX,XTERM);
4744 LOP(OP_IOCTL,XTERM);
4756 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4788 LOP(OP_LISTEN,XTERM);
4797 s = scan_pat(s,OP_MATCH);
4798 TERM(sublex_start());
4801 LOP(OP_MAPSTART, XREF);
4804 LOP(OP_MKDIR,XTERM);
4807 LOP(OP_MSGCTL,XTERM);
4810 LOP(OP_MSGGET,XTERM);
4813 LOP(OP_MSGRCV,XTERM);
4816 LOP(OP_MSGSND,XTERM);
4822 if (isIDFIRST_lazy_if(s,UTF)) {
4823 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4824 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4826 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4827 if (!PL_in_my_stash) {
4830 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4838 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4845 if (PL_expect != XSTATE)
4846 yyerror("\"no\" not allowed in expression");
4847 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4848 s = force_version(s, FALSE);
4853 if (*s == '(' || (s = skipspace(s), *s == '('))
4860 if (isIDFIRST_lazy_if(s,UTF)) {
4862 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4863 for (t=d; *t && isSPACE(*t); t++) ;
4864 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4866 && !(t[0] == '=' && t[1] == '>')
4868 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4869 "Precedence problem: open %.*s should be open(%.*s)",
4870 d - s, s, d - s, s);
4876 yylval.ival = OP_OR;
4886 LOP(OP_OPEN_DIR,XTERM);
4889 checkcomma(s,PL_tokenbuf,"filehandle");
4893 checkcomma(s,PL_tokenbuf,"filehandle");
4912 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4916 LOP(OP_PIPE_OP,XTERM);
4919 s = scan_str(s,FALSE,FALSE);
4921 missingterm((char*)0);
4922 yylval.ival = OP_CONST;
4923 TERM(sublex_start());
4929 s = scan_str(s,FALSE,FALSE);
4931 missingterm((char*)0);
4933 if (SvCUR(PL_lex_stuff)) {
4936 d = SvPV_force(PL_lex_stuff, len);
4939 for (; isSPACE(*d) && len; --len, ++d) ;
4942 if (!warned && ckWARN(WARN_QW)) {
4943 for (; !isSPACE(*d) && len; --len, ++d) {
4945 Perl_warner(aTHX_ packWARN(WARN_QW),
4946 "Possible attempt to separate words with commas");
4949 else if (*d == '#') {
4950 Perl_warner(aTHX_ packWARN(WARN_QW),
4951 "Possible attempt to put comments in qw() list");
4957 for (; !isSPACE(*d) && len; --len, ++d) ;
4959 sv = newSVpvn(b, d-b);
4960 if (DO_UTF8(PL_lex_stuff))
4962 words = append_elem(OP_LIST, words,
4963 newSVOP(OP_CONST, 0, tokeq(sv)));
4967 PL_nextval[PL_nexttoke].opval = words;
4972 SvREFCNT_dec(PL_lex_stuff);
4973 PL_lex_stuff = Nullsv;
4979 s = scan_str(s,FALSE,FALSE);
4981 missingterm((char*)0);
4982 yylval.ival = OP_STRINGIFY;
4983 if (SvIVX(PL_lex_stuff) == '\'')
4984 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4985 TERM(sublex_start());
4988 s = scan_pat(s,OP_QR);
4989 TERM(sublex_start());
4992 s = scan_str(s,FALSE,FALSE);
4994 missingterm((char*)0);
4995 yylval.ival = OP_BACKTICK;
4997 TERM(sublex_start());
5005 s = force_version(s, FALSE);
5007 else if (*s != 'v' || !isDIGIT(s[1])
5008 || (s = force_version(s, TRUE), *s == 'v'))
5010 *PL_tokenbuf = '\0';
5011 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5012 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5013 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5015 yyerror("<> should be quotes");
5023 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5027 LOP(OP_RENAME,XTERM);
5036 LOP(OP_RINDEX,XTERM);
5046 UNIDOR(OP_READLINE);
5059 LOP(OP_REVERSE,XTERM);
5062 UNIDOR(OP_READLINK);
5070 TERM(sublex_start());
5072 TOKEN(1); /* force error */
5081 LOP(OP_SELECT,XTERM);
5087 LOP(OP_SEMCTL,XTERM);
5090 LOP(OP_SEMGET,XTERM);
5093 LOP(OP_SEMOP,XTERM);
5099 LOP(OP_SETPGRP,XTERM);
5101 case KEY_setpriority:
5102 LOP(OP_SETPRIORITY,XTERM);
5104 case KEY_sethostent:
5110 case KEY_setservent:
5113 case KEY_setprotoent:
5123 LOP(OP_SEEKDIR,XTERM);
5125 case KEY_setsockopt:
5126 LOP(OP_SSOCKOPT,XTERM);
5132 LOP(OP_SHMCTL,XTERM);
5135 LOP(OP_SHMGET,XTERM);
5138 LOP(OP_SHMREAD,XTERM);
5141 LOP(OP_SHMWRITE,XTERM);
5144 LOP(OP_SHUTDOWN,XTERM);
5153 LOP(OP_SOCKET,XTERM);
5155 case KEY_socketpair:
5156 LOP(OP_SOCKPAIR,XTERM);
5159 checkcomma(s,PL_tokenbuf,"subroutine name");
5161 if (*s == ';' || *s == ')') /* probably a close */
5162 Perl_croak(aTHX_ "sort is now a reserved word");
5164 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5168 LOP(OP_SPLIT,XTERM);
5171 LOP(OP_SPRINTF,XTERM);
5174 LOP(OP_SPLICE,XTERM);
5189 LOP(OP_SUBSTR,XTERM);
5195 char tmpbuf[sizeof PL_tokenbuf];
5196 SSize_t tboffset = 0;
5197 expectation attrful;
5198 bool have_name, have_proto, bad_proto;
5203 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5204 (*s == ':' && s[1] == ':'))
5207 attrful = XATTRBLOCK;
5208 /* remember buffer pos'n for later force_word */
5209 tboffset = s - PL_oldbufptr;
5210 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5211 if (strchr(tmpbuf, ':'))
5212 sv_setpv(PL_subname, tmpbuf);
5214 sv_setsv(PL_subname,PL_curstname);
5215 sv_catpvn(PL_subname,"::",2);
5216 sv_catpvn(PL_subname,tmpbuf,len);
5223 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5224 PL_expect = XTERMBLOCK;
5225 attrful = XATTRTERM;
5226 sv_setpv(PL_subname,"?");
5230 if (key == KEY_format) {
5232 PL_lex_formbrack = PL_lex_brackets + 1;
5234 (void) force_word(PL_oldbufptr + tboffset, WORD,
5239 /* Look for a prototype */
5243 s = scan_str(s,FALSE,FALSE);
5245 Perl_croak(aTHX_ "Prototype not terminated");
5246 /* strip spaces and check for bad characters */
5247 d = SvPVX(PL_lex_stuff);
5250 for (p = d; *p; ++p) {
5253 if (!strchr("$@%*;[]&\\", *p))
5258 if (bad_proto && ckWARN(WARN_SYNTAX))
5259 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5260 "Illegal character in prototype for %"SVf" : %s",
5262 SvCUR(PL_lex_stuff) = tmp;
5270 if (*s == ':' && s[1] != ':')
5271 PL_expect = attrful;
5272 else if (*s != '{' && key == KEY_sub) {
5274 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5276 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5280 PL_nextval[PL_nexttoke].opval =
5281 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5282 PL_lex_stuff = Nullsv;
5286 sv_setpv(PL_subname,
5287 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5290 (void) force_word(PL_oldbufptr + tboffset, WORD,
5299 LOP(OP_SYSTEM,XREF);
5302 LOP(OP_SYMLINK,XTERM);
5305 LOP(OP_SYSCALL,XTERM);
5308 LOP(OP_SYSOPEN,XTERM);
5311 LOP(OP_SYSSEEK,XTERM);
5314 LOP(OP_SYSREAD,XTERM);
5317 LOP(OP_SYSWRITE,XTERM);
5321 TERM(sublex_start());
5342 LOP(OP_TRUNCATE,XTERM);
5354 yylval.ival = CopLINE(PL_curcop);
5358 yylval.ival = CopLINE(PL_curcop);
5362 LOP(OP_UNLINK,XTERM);
5368 LOP(OP_UNPACK,XTERM);
5371 LOP(OP_UTIME,XTERM);
5377 LOP(OP_UNSHIFT,XTERM);
5380 if (PL_expect != XSTATE)
5381 yyerror("\"use\" not allowed in expression");
5383 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5384 s = force_version(s, TRUE);
5385 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5386 PL_nextval[PL_nexttoke].opval = Nullop;
5389 else if (*s == 'v') {
5390 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5391 s = force_version(s, FALSE);
5395 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5396 s = force_version(s, FALSE);
5408 yylval.ival = CopLINE(PL_curcop);
5412 PL_hints |= HINT_BLOCK_SCOPE;
5419 LOP(OP_WAITPID,XTERM);
5428 ctl_l[0] = toCTRL('L');
5430 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5433 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5438 if (PL_expect == XOPERATOR)
5444 yylval.ival = OP_XOR;
5449 TERM(sublex_start());
5454 #pragma segment Main
5458 S_pending_ident(pTHX)
5461 register I32 tmp = 0;
5462 /* pit holds the identifier we read and pending_ident is reset */
5463 char pit = PL_pending_ident;
5464 PL_pending_ident = 0;
5466 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5467 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5469 /* if we're in a my(), we can't allow dynamics here.
5470 $foo'bar has already been turned into $foo::bar, so
5471 just check for colons.
5473 if it's a legal name, the OP is a PADANY.
5476 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5477 if (strchr(PL_tokenbuf,':'))
5478 yyerror(Perl_form(aTHX_ "No package name allowed for "
5479 "variable %s in \"our\"",
5481 tmp = allocmy(PL_tokenbuf);
5484 if (strchr(PL_tokenbuf,':'))
5485 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5487 yylval.opval = newOP(OP_PADANY, 0);
5488 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5494 build the ops for accesses to a my() variable.
5496 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5497 then used in a comparison. This catches most, but not
5498 all cases. For instance, it catches
5499 sort { my($a); $a <=> $b }
5501 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5502 (although why you'd do that is anyone's guess).
5505 if (!strchr(PL_tokenbuf,':')) {
5507 tmp = pad_findmy(PL_tokenbuf);
5508 if (tmp != NOT_IN_PAD) {
5509 /* might be an "our" variable" */
5510 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5511 /* build ops for a bareword */
5512 SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0);
5513 sv_catpvn(sym, "::", 2);
5514 sv_catpv(sym, PL_tokenbuf+1);
5515 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5516 yylval.opval->op_private = OPpCONST_ENTERED;
5517 gv_fetchpv(SvPVX(sym),
5519 ? (GV_ADDMULTI | GV_ADDINEVAL)
5522 ((PL_tokenbuf[0] == '$') ? SVt_PV
5523 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5528 /* if it's a sort block and they're naming $a or $b */
5529 if (PL_last_lop_op == OP_SORT &&
5530 PL_tokenbuf[0] == '$' &&
5531 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5534 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5535 d < PL_bufend && *d != '\n';
5538 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5539 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5545 yylval.opval = newOP(OP_PADANY, 0);
5546 yylval.opval->op_targ = tmp;
5552 Whine if they've said @foo in a doublequoted string,
5553 and @foo isn't a variable we can find in the symbol
5556 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5557 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5558 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5559 && ckWARN(WARN_AMBIGUOUS))
5561 /* Downgraded from fatal to warning 20000522 mjd */
5562 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5563 "Possible unintended interpolation of %s in string",
5568 /* build ops for a bareword */
5569 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5570 yylval.opval->op_private = OPpCONST_ENTERED;
5571 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5572 ((PL_tokenbuf[0] == '$') ? SVt_PV
5573 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5579 Perl_keyword(pTHX_ register char *d, I32 len)
5584 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5585 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5586 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5587 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5588 if (strEQ(d,"__END__")) return KEY___END__;
5592 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5597 if (strEQ(d,"and")) return -KEY_and;
5598 if (strEQ(d,"abs")) return -KEY_abs;
5601 if (strEQ(d,"alarm")) return -KEY_alarm;
5602 if (strEQ(d,"atan2")) return -KEY_atan2;
5605 if (strEQ(d,"accept")) return -KEY_accept;
5610 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5613 if (strEQ(d,"bless")) return -KEY_bless;
5614 if (strEQ(d,"bind")) return -KEY_bind;
5615 if (strEQ(d,"binmode")) return -KEY_binmode;
5618 if (strEQ(d,"CORE")) return -KEY_CORE;
5619 if (strEQ(d,"CHECK")) return KEY_CHECK;
5624 if (strEQ(d,"cmp")) return -KEY_cmp;
5625 if (strEQ(d,"chr")) return -KEY_chr;
5626 if (strEQ(d,"cos")) return -KEY_cos;
5629 if (strEQ(d,"chop")) return -KEY_chop;
5632 if (strEQ(d,"close")) return -KEY_close;
5633 if (strEQ(d,"chdir")) return -KEY_chdir;
5634 if (strEQ(d,"chomp")) return -KEY_chomp;
5635 if (strEQ(d,"chmod")) return -KEY_chmod;
5636 if (strEQ(d,"chown")) return -KEY_chown;
5637 if (strEQ(d,"crypt")) return -KEY_crypt;
5640 if (strEQ(d,"chroot")) return -KEY_chroot;
5641 if (strEQ(d,"caller")) return -KEY_caller;
5644 if (strEQ(d,"connect")) return -KEY_connect;
5647 if (strEQ(d,"closedir")) return -KEY_closedir;
5648 if (strEQ(d,"continue")) return -KEY_continue;
5653 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5658 if (strEQ(d,"do")) return KEY_do;
5661 if (strEQ(d,"die")) return -KEY_die;
5664 if (strEQ(d,"dump")) return -KEY_dump;
5667 if (strEQ(d,"delete")) return KEY_delete;
5670 if (strEQ(d,"defined")) return KEY_defined;
5671 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5674 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5679 if (strEQ(d,"END")) return KEY_END;
5684 if (strEQ(d,"eq")) return -KEY_eq;
5687 if (strEQ(d,"eof")) return -KEY_eof;
5688 if (strEQ(d,"err")) return -KEY_err;
5689 if (strEQ(d,"exp")) return -KEY_exp;
5692 if (strEQ(d,"else")) return KEY_else;
5693 if (strEQ(d,"exit")) return -KEY_exit;
5694 if (strEQ(d,"eval")) return KEY_eval;
5695 if (strEQ(d,"exec")) return -KEY_exec;
5696 if (strEQ(d,"each")) return -KEY_each;
5699 if (strEQ(d,"elsif")) return KEY_elsif;
5702 if (strEQ(d,"exists")) return KEY_exists;
5703 if (strEQ(d,"elseif") && ckWARN_d(WARN_SYNTAX))
5704 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5705 "elseif should be elsif");
5708 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5709 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5712 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5715 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5716 if (strEQ(d,"endservent")) return -KEY_endservent;
5719 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5726 if (strEQ(d,"for")) return KEY_for;
5729 if (strEQ(d,"fork")) return -KEY_fork;
5732 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5733 if (strEQ(d,"flock")) return -KEY_flock;
5736 if (strEQ(d,"format")) return KEY_format;
5737 if (strEQ(d,"fileno")) return -KEY_fileno;
5740 if (strEQ(d,"foreach")) return KEY_foreach;
5743 if (strEQ(d,"formline")) return -KEY_formline;
5748 if (strnEQ(d,"get",3)) {
5753 if (strEQ(d,"ppid")) return -KEY_getppid;
5754 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5757 if (strEQ(d,"pwent")) return -KEY_getpwent;
5758 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5759 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5762 if (strEQ(d,"peername")) return -KEY_getpeername;
5763 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5764 if (strEQ(d,"priority")) return -KEY_getpriority;
5767 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5770 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5774 else if (*d == 'h') {
5775 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5776 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5777 if (strEQ(d,"hostent")) return -KEY_gethostent;
5779 else if (*d == 'n') {
5780 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5781 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5782 if (strEQ(d,"netent")) return -KEY_getnetent;
5784 else if (*d == 's') {
5785 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5786 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5787 if (strEQ(d,"servent")) return -KEY_getservent;
5788 if (strEQ(d,"sockname")) return -KEY_getsockname;
5789 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5791 else if (*d == 'g') {
5792 if (strEQ(d,"grent")) return -KEY_getgrent;
5793 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5794 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5796 else if (*d == 'l') {
5797 if (strEQ(d,"login")) return -KEY_getlogin;
5799 else if (*d == 'c' && d[1] == '\0') return -KEY_getc;
5804 if (strEQ(d,"gt")) return -KEY_gt;
5805 if (strEQ(d,"ge")) return -KEY_ge;
5808 if (strEQ(d,"grep")) return KEY_grep;
5809 if (strEQ(d,"goto")) return KEY_goto;
5810 if (strEQ(d,"glob")) return KEY_glob;
5813 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5818 if (strEQ(d,"hex")) return -KEY_hex;
5821 if (strEQ(d,"INIT")) return KEY_INIT;
5826 if (strEQ(d,"if")) return KEY_if;
5829 if (strEQ(d,"int")) return -KEY_int;
5832 if (strEQ(d,"index")) return -KEY_index;
5833 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5838 if (strEQ(d,"join")) return -KEY_join;
5842 if (strEQ(d,"keys")) return -KEY_keys;
5843 if (strEQ(d,"kill")) return -KEY_kill;
5849 if (strEQ(d,"lt")) return -KEY_lt;
5850 if (strEQ(d,"le")) return -KEY_le;
5851 if (strEQ(d,"lc")) return -KEY_lc;
5854 if (strEQ(d,"log")) return -KEY_log;
5857 if (strEQ(d,"last")) return KEY_last;
5858 if (strEQ(d,"link")) return -KEY_link;
5859 if (strEQ(d,"lock")) return -KEY_lock;
5862 if (strEQ(d,"local")) return KEY_local;
5863 if (strEQ(d,"lstat")) return -KEY_lstat;
5866 if (strEQ(d,"length")) return -KEY_length;
5867 if (strEQ(d,"listen")) return -KEY_listen;
5870 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5873 if (strEQ(d,"localtime")) return -KEY_localtime;
5879 case 1: return KEY_m;
5881 if (strEQ(d,"my")) return KEY_my;
5884 if (strEQ(d,"map")) return KEY_map;
5887 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5890 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5891 if (strEQ(d,"msgget")) return -KEY_msgget;
5892 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5893 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5898 if (strEQ(d,"next")) return KEY_next;
5899 if (strEQ(d,"ne")) return -KEY_ne;
5900 if (strEQ(d,"not")) return -KEY_not;
5901 if (strEQ(d,"no")) return KEY_no;
5906 if (strEQ(d,"or")) return -KEY_or;
5909 if (strEQ(d,"ord")) return -KEY_ord;
5910 if (strEQ(d,"oct")) return -KEY_oct;
5911 if (strEQ(d,"our")) return KEY_our;
5914 if (strEQ(d,"open")) return -KEY_open;
5917 if (strEQ(d,"opendir")) return -KEY_opendir;
5924 if (strEQ(d,"pop")) return -KEY_pop;
5925 if (strEQ(d,"pos")) return KEY_pos;
5928 if (strEQ(d,"push")) return -KEY_push;
5929 if (strEQ(d,"pack")) return -KEY_pack;
5930 if (strEQ(d,"pipe")) return -KEY_pipe;
5933 if (strEQ(d,"print")) return KEY_print;
5936 if (strEQ(d,"printf")) return KEY_printf;
5939 if (strEQ(d,"package")) return KEY_package;
5942 if (strEQ(d,"prototype")) return KEY_prototype;
5949 else if (len == 2) {
5951 case 'r': return KEY_qr;
5952 case 'q': return KEY_qq;
5953 case 'w': return KEY_qw;
5954 case 'x': return KEY_qx;
5957 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5962 if (strEQ(d,"ref")) return -KEY_ref;
5965 if (strEQ(d,"read")) return -KEY_read;
5966 if (strEQ(d,"rand")) return -KEY_rand;
5967 if (strEQ(d,"recv")) return -KEY_recv;
5968 if (strEQ(d,"redo")) return KEY_redo;
5971 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5972 if (strEQ(d,"reset")) return -KEY_reset;
5975 if (strEQ(d,"return")) return KEY_return;
5976 if (strEQ(d,"rename")) return -KEY_rename;
5977 if (strEQ(d,"rindex")) return -KEY_rindex;
5980 if (strEQ(d,"require")) return KEY_require;
5981 if (strEQ(d,"reverse")) return -KEY_reverse;
5982 if (strEQ(d,"readdir")) return -KEY_readdir;
5985 if (strEQ(d,"readlink")) return -KEY_readlink;
5986 if (strEQ(d,"readline")) return -KEY_readline;
5987 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5990 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5996 case 0: return KEY_s;
5998 if (strEQ(d,"scalar")) return KEY_scalar;
6003 if (strEQ(d,"seek")) return -KEY_seek;
6004 if (strEQ(d,"send")) return -KEY_send;
6007 if (strEQ(d,"semop")) return -KEY_semop;
6010 if (strEQ(d,"select")) return -KEY_select;
6011 if (strEQ(d,"semctl")) return -KEY_semctl;
6012 if (strEQ(d,"semget")) return -KEY_semget;
6015 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
6016 if (strEQ(d,"seekdir")) return -KEY_seekdir;
6019 if (strEQ(d,"setpwent")) return -KEY_setpwent;
6020 if (strEQ(d,"setgrent")) return -KEY_setgrent;
6023 if (strEQ(d,"setnetent")) return -KEY_setnetent;
6026 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
6027 if (strEQ(d,"sethostent")) return -KEY_sethostent;
6028 if (strEQ(d,"setservent")) return -KEY_setservent;
6031 if (strEQ(d,"setpriority")) return -KEY_setpriority;
6032 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
6039 if (strEQ(d,"shift")) return -KEY_shift;
6042 if (strEQ(d,"shmctl")) return -KEY_shmctl;
6043 if (strEQ(d,"shmget")) return -KEY_shmget;
6046 if (strEQ(d,"shmread")) return -KEY_shmread;
6049 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
6050 if (strEQ(d,"shutdown")) return -KEY_shutdown;
6055 if (strEQ(d,"sin")) return -KEY_sin;
6058 if (strEQ(d,"sleep")) return -KEY_sleep;
6061 if (strEQ(d,"sort")) return KEY_sort;
6062 if (strEQ(d,"socket")) return -KEY_socket;
6063 if (strEQ(d,"socketpair")) return -KEY_socketpair;
6066 if (strEQ(d,"split")) return KEY_split;
6067 if (strEQ(d,"sprintf")) return -KEY_sprintf;
6068 if (strEQ(d,"splice")) return -KEY_splice;
6071 if (strEQ(d,"sqrt")) return -KEY_sqrt;
6074 if (strEQ(d,"srand")) return -KEY_srand;
6077 if (strEQ(d,"stat")) return -KEY_stat;
6078 if (strEQ(d,"study")) return KEY_study;
6081 if (strEQ(d,"substr")) return -KEY_substr;
6082 if (strEQ(d,"sub")) return KEY_sub;
6087 if (strEQ(d,"system")) return -KEY_system;
6090 if (strEQ(d,"symlink")) return -KEY_symlink;
6091 if (strEQ(d,"syscall")) return -KEY_syscall;
6092 if (strEQ(d,"sysopen")) return -KEY_sysopen;
6093 if (strEQ(d,"sysread")) return -KEY_sysread;
6094 if (strEQ(d,"sysseek")) return -KEY_sysseek;
6097 if (strEQ(d,"syswrite")) return -KEY_syswrite;
6106 if (strEQ(d,"tr")) return KEY_tr;
6109 if (strEQ(d,"tie")) return KEY_tie;
6112 if (strEQ(d,"tell")) return -KEY_tell;
6113 if (strEQ(d,"tied")) return KEY_tied;
6114 if (strEQ(d,"time")) return -KEY_time;
6117 if (strEQ(d,"times")) return -KEY_times;
6120 if (strEQ(d,"telldir")) return -KEY_telldir;
6123 if (strEQ(d,"truncate")) return -KEY_truncate;
6130 if (strEQ(d,"uc")) return -KEY_uc;
6133 if (strEQ(d,"use")) return KEY_use;
6136 if (strEQ(d,"undef")) return KEY_undef;
6137 if (strEQ(d,"until")) return KEY_until;
6138 if (strEQ(d,"untie")) return KEY_untie;
6139 if (strEQ(d,"utime")) return -KEY_utime;
6140 if (strEQ(d,"umask")) return -KEY_umask;
6143 if (strEQ(d,"unless")) return KEY_unless;
6144 if (strEQ(d,"unpack")) return -KEY_unpack;
6145 if (strEQ(d,"unlink")) return -KEY_unlink;
6148 if (strEQ(d,"unshift")) return -KEY_unshift;
6149 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
6154 if (strEQ(d,"values")) return -KEY_values;
6155 if (strEQ(d,"vec")) return -KEY_vec;
6160 if (strEQ(d,"warn")) return -KEY_warn;
6161 if (strEQ(d,"wait")) return -KEY_wait;
6164 if (strEQ(d,"while")) return KEY_while;
6165 if (strEQ(d,"write")) return -KEY_write;
6168 if (strEQ(d,"waitpid")) return -KEY_waitpid;
6171 if (strEQ(d,"wantarray")) return -KEY_wantarray;
6176 if (len == 1) return -KEY_x;
6177 if (strEQ(d,"xor")) return -KEY_xor;
6180 if (len == 1) return KEY_y;
6189 S_checkcomma(pTHX_ register char *s, char *name, char *what)
6193 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
6194 if (ckWARN(WARN_SYNTAX)) {
6196 for (w = s+2; *w && level; w++) {
6203 for (; *w && isSPACE(*w); w++) ;
6204 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
6205 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6206 "%s (...) interpreted as function",name);
6209 while (s < PL_bufend && isSPACE(*s))
6213 while (s < PL_bufend && isSPACE(*s))
6215 if (isIDFIRST_lazy_if(s,UTF)) {
6217 while (isALNUM_lazy_if(s,UTF))
6219 while (s < PL_bufend && isSPACE(*s))
6224 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
6228 Perl_croak(aTHX_ "No comma allowed after %s", what);
6233 /* Either returns sv, or mortalizes sv and returns a new SV*.
6234 Best used as sv=new_constant(..., sv, ...).
6235 If s, pv are NULL, calls subroutine with one argument,
6236 and type is used with error messages only. */
6239 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
6243 HV *table = GvHV(PL_hintgv); /* ^H */
6247 const char *why1, *why2, *why3;
6249 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
6252 why2 = strEQ(key,"charnames")
6253 ? "(possibly a missing \"use charnames ...\")"
6255 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
6256 (type ? type: "undef"), why2);
6258 /* This is convoluted and evil ("goto considered harmful")
6259 * but I do not understand the intricacies of all the different
6260 * failure modes of %^H in here. The goal here is to make
6261 * the most probable error message user-friendly. --jhi */
6266 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
6267 (type ? type: "undef"), why1, why2, why3);
6269 yyerror(SvPVX(msg));
6273 cvp = hv_fetch(table, key, strlen(key), FALSE);
6274 if (!cvp || !SvOK(*cvp)) {
6277 why3 = "} is not defined";
6280 sv_2mortal(sv); /* Parent created it permanently */
6283 pv = sv_2mortal(newSVpvn(s, len));
6285 typesv = sv_2mortal(newSVpv(type, 0));
6287 typesv = &PL_sv_undef;
6289 PUSHSTACKi(PERLSI_OVERLOAD);
6301 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
6305 /* Check the eval first */
6306 if (!PL_in_eval && SvTRUE(ERRSV)) {
6308 sv_catpv(ERRSV, "Propagated");
6309 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6311 res = SvREFCNT_inc(sv);
6315 (void)SvREFCNT_inc(res);
6324 why1 = "Call to &{$^H{";
6326 why3 = "}} did not return a defined value";
6335 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6337 register char *d = dest;
6338 register char *e = d + destlen - 3; /* two-character token, ending NUL */
6341 Perl_croak(aTHX_ ident_too_long);
6342 if (isALNUM(*s)) /* UTF handled below */
6344 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6349 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6353 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6354 char *t = s + UTF8SKIP(s);
6355 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6357 if (d + (t - s) > e)
6358 Perl_croak(aTHX_ ident_too_long);
6359 Copy(s, d, t - s, char);
6372 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6382 e = d + destlen - 3; /* two-character token, ending NUL */
6384 while (isDIGIT(*s)) {
6386 Perl_croak(aTHX_ ident_too_long);
6393 Perl_croak(aTHX_ ident_too_long);
6394 if (isALNUM(*s)) /* UTF handled below */
6396 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6401 else if (*s == ':' && s[1] == ':') {
6405 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6406 char *t = s + UTF8SKIP(s);
6407 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6409 if (d + (t - s) > e)
6410 Perl_croak(aTHX_ ident_too_long);
6411 Copy(s, d, t - s, char);
6422 if (PL_lex_state != LEX_NORMAL)
6423 PL_lex_state = LEX_INTERPENDMAYBE;
6426 if (*s == '$' && s[1] &&
6427 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
6440 if (*d == '^' && *s && isCONTROLVAR(*s)) {
6445 if (isSPACE(s[-1])) {
6448 if (!SPACE_OR_TAB(ch)) {
6454 if (isIDFIRST_lazy_if(d,UTF)) {
6458 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6460 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6463 Copy(s, d, e - s, char);
6468 while ((isALNUM(*s) || *s == ':') && d < e)
6471 Perl_croak(aTHX_ ident_too_long);
6474 while (s < send && SPACE_OR_TAB(*s)) s++;
6475 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6476 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6477 const char *brack = *s == '[' ? "[...]" : "{...}";
6478 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6479 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6480 funny, dest, brack, funny, dest, brack);
6483 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6487 /* Handle extended ${^Foo} variables
6488 * 1999-02-27 mjd-perl-patch@plover.com */
6489 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6493 while (isALNUM(*s) && d < e) {
6497 Perl_croak(aTHX_ ident_too_long);
6502 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
6503 PL_lex_state = LEX_INTERPEND;
6508 if (PL_lex_state == LEX_NORMAL) {
6509 if (ckWARN(WARN_AMBIGUOUS) &&
6510 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6512 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6513 "Ambiguous use of %c{%s} resolved to %c%s",
6514 funny, dest, funny, dest);
6519 s = bracket; /* let the parser handle it */
6523 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6524 PL_lex_state = LEX_INTERPEND;
6529 Perl_pmflag(pTHX_ U32* pmfl, int ch)
6534 *pmfl |= PMf_GLOBAL;
6536 *pmfl |= PMf_CONTINUE;
6540 *pmfl |= PMf_MULTILINE;
6542 *pmfl |= PMf_SINGLELINE;
6544 *pmfl |= PMf_EXTENDED;
6548 S_scan_pat(pTHX_ char *start, I32 type)
6553 s = scan_str(start,FALSE,FALSE);
6555 Perl_croak(aTHX_ "Search pattern not terminated");
6557 pm = (PMOP*)newPMOP(type, 0);
6558 if (PL_multi_open == '?')
6559 pm->op_pmflags |= PMf_ONCE;
6561 while (*s && strchr("iomsx", *s))
6562 pmflag(&pm->op_pmflags,*s++);
6565 while (*s && strchr("iogcmsx", *s))
6566 pmflag(&pm->op_pmflags,*s++);
6568 /* issue a warning if /c is specified,but /g is not */
6569 if (ckWARN(WARN_REGEXP) &&
6570 (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
6572 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
6575 pm->op_pmpermflags = pm->op_pmflags;
6577 PL_lex_op = (OP*)pm;
6578 yylval.ival = OP_MATCH;
6583 S_scan_subst(pTHX_ char *start)
6590 yylval.ival = OP_NULL;
6592 s = scan_str(start,FALSE,FALSE);
6595 Perl_croak(aTHX_ "Substitution pattern not terminated");
6597 if (s[-1] == PL_multi_open)
6600 first_start = PL_multi_start;
6601 s = scan_str(s,FALSE,FALSE);
6604 SvREFCNT_dec(PL_lex_stuff);
6605 PL_lex_stuff = Nullsv;
6607 Perl_croak(aTHX_ "Substitution replacement not terminated");
6609 PL_multi_start = first_start; /* so whole substitution is taken together */
6611 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6617 else if (strchr("iogcmsx", *s))
6618 pmflag(&pm->op_pmflags,*s++);
6623 /* /c is not meaningful with s/// */
6624 if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
6626 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
6631 PL_sublex_info.super_bufptr = s;
6632 PL_sublex_info.super_bufend = PL_bufend;
6634 pm->op_pmflags |= PMf_EVAL;
6635 repl = newSVpvn("",0);
6637 sv_catpv(repl, es ? "eval " : "do ");
6638 sv_catpvn(repl, "{ ", 2);
6639 sv_catsv(repl, PL_lex_repl);
6640 sv_catpvn(repl, " };", 2);
6642 SvREFCNT_dec(PL_lex_repl);
6646 pm->op_pmpermflags = pm->op_pmflags;
6647 PL_lex_op = (OP*)pm;
6648 yylval.ival = OP_SUBST;
6653 S_scan_trans(pTHX_ char *start)
6662 yylval.ival = OP_NULL;
6664 s = scan_str(start,FALSE,FALSE);
6666 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6667 if (s[-1] == PL_multi_open)
6670 s = scan_str(s,FALSE,FALSE);
6673 SvREFCNT_dec(PL_lex_stuff);
6674 PL_lex_stuff = Nullsv;
6676 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6679 complement = del = squash = 0;
6683 complement = OPpTRANS_COMPLEMENT;
6686 del = OPpTRANS_DELETE;
6689 squash = OPpTRANS_SQUASH;
6698 New(803, tbl, complement&&!del?258:256, short);
6699 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6700 o->op_private &= ~OPpTRANS_ALL;
6701 o->op_private |= del|squash|complement|
6702 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6703 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6706 yylval.ival = OP_TRANS;
6711 S_scan_heredoc(pTHX_ register char *s)
6714 I32 op_type = OP_SCALAR;
6721 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6725 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6728 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6729 if (*peek == '`' || *peek == '\'' || *peek =='"') {
6732 s = delimcpy(d, e, s, PL_bufend, term, &len);
6742 if (!isALNUM_lazy_if(s,UTF))
6743 deprecate_old("bare << to mean <<\"\"");
6744 for (; isALNUM_lazy_if(s,UTF); s++) {
6749 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6750 Perl_croak(aTHX_ "Delimiter for here document is too long");
6753 len = d - PL_tokenbuf;
6754 #ifndef PERL_STRICT_CR
6755 d = strchr(s, '\r');
6759 while (s < PL_bufend) {
6765 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6774 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6779 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6780 herewas = newSVpvn(s,PL_bufend-s);
6782 s--, herewas = newSVpvn(s,d-s);
6783 s += SvCUR(herewas);
6785 tmpstr = NEWSV(87,79);
6786 sv_upgrade(tmpstr, SVt_PVIV);
6791 else if (term == '`') {
6792 op_type = OP_BACKTICK;
6793 SvIVX(tmpstr) = '\\';
6797 PL_multi_start = CopLINE(PL_curcop);
6798 PL_multi_open = PL_multi_close = '<';
6799 term = *PL_tokenbuf;
6800 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6801 char *bufptr = PL_sublex_info.super_bufptr;
6802 char *bufend = PL_sublex_info.super_bufend;
6803 char *olds = s - SvCUR(herewas);
6804 s = strchr(bufptr, '\n');
6808 while (s < bufend &&
6809 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6811 CopLINE_inc(PL_curcop);
6814 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6815 missingterm(PL_tokenbuf);
6817 sv_setpvn(herewas,bufptr,d-bufptr+1);
6818 sv_setpvn(tmpstr,d+1,s-d);
6820 sv_catpvn(herewas,s,bufend-s);
6821 Copy(SvPVX(herewas),bufptr,SvCUR(herewas) + 1,char);
6828 while (s < PL_bufend &&
6829 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6831 CopLINE_inc(PL_curcop);
6833 if (s >= PL_bufend) {
6834 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6835 missingterm(PL_tokenbuf);
6837 sv_setpvn(tmpstr,d+1,s-d);
6839 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6841 sv_catpvn(herewas,s,PL_bufend-s);
6842 sv_setsv(PL_linestr,herewas);
6843 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6844 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6845 PL_last_lop = PL_last_uni = Nullch;
6848 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6849 while (s >= PL_bufend) { /* multiple line string? */
6851 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6852 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6853 missingterm(PL_tokenbuf);
6855 CopLINE_inc(PL_curcop);
6856 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6857 PL_last_lop = PL_last_uni = Nullch;
6858 #ifndef PERL_STRICT_CR
6859 if (PL_bufend - PL_linestart >= 2) {
6860 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6861 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6863 PL_bufend[-2] = '\n';
6865 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6867 else if (PL_bufend[-1] == '\r')
6868 PL_bufend[-1] = '\n';
6870 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6871 PL_bufend[-1] = '\n';
6873 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6874 SV *sv = NEWSV(88,0);
6876 sv_upgrade(sv, SVt_PVMG);
6877 sv_setsv(sv,PL_linestr);
6880 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6882 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6883 STRLEN off = PL_bufend - 1 - SvPVX(PL_linestr);
6884 *(SvPVX(PL_linestr) + off ) = ' ';
6885 sv_catsv(PL_linestr,herewas);
6886 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6887 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
6891 sv_catsv(tmpstr,PL_linestr);
6896 PL_multi_end = CopLINE(PL_curcop);
6897 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6898 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6899 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6901 SvREFCNT_dec(herewas);
6903 if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6905 else if (PL_encoding)
6906 sv_recode_to_utf8(tmpstr, PL_encoding);
6908 PL_lex_stuff = tmpstr;
6909 yylval.ival = op_type;
6914 takes: current position in input buffer
6915 returns: new position in input buffer
6916 side-effects: yylval and lex_op are set.
6921 <FH> read from filehandle
6922 <pkg::FH> read from package qualified filehandle
6923 <pkg'FH> read from package qualified filehandle
6924 <$fh> read from filehandle in $fh
6930 S_scan_inputsymbol(pTHX_ char *start)
6932 register char *s = start; /* current position in buffer */
6938 d = PL_tokenbuf; /* start of temp holding space */
6939 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6940 end = strchr(s, '\n');
6943 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6945 /* die if we didn't have space for the contents of the <>,
6946 or if it didn't end, or if we see a newline
6949 if (len >= sizeof PL_tokenbuf)
6950 Perl_croak(aTHX_ "Excessively long <> operator");
6952 Perl_croak(aTHX_ "Unterminated <> operator");
6957 Remember, only scalar variables are interpreted as filehandles by
6958 this code. Anything more complex (e.g., <$fh{$num}>) will be
6959 treated as a glob() call.
6960 This code makes use of the fact that except for the $ at the front,
6961 a scalar variable and a filehandle look the same.
6963 if (*d == '$' && d[1]) d++;
6965 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6966 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6969 /* If we've tried to read what we allow filehandles to look like, and
6970 there's still text left, then it must be a glob() and not a getline.
6971 Use scan_str to pull out the stuff between the <> and treat it
6972 as nothing more than a string.
6975 if (d - PL_tokenbuf != len) {
6976 yylval.ival = OP_GLOB;
6978 s = scan_str(start,FALSE,FALSE);
6980 Perl_croak(aTHX_ "Glob not terminated");
6984 bool readline_overriden = FALSE;
6985 GV *gv_readline = Nullgv;
6987 /* we're in a filehandle read situation */
6990 /* turn <> into <ARGV> */
6992 Copy("ARGV",d,5,char);
6994 /* Check whether readline() is overriden */
6995 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
6996 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
6998 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
6999 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
7000 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
7001 readline_overriden = TRUE;
7003 /* if <$fh>, create the ops to turn the variable into a
7009 /* try to find it in the pad for this block, otherwise find
7010 add symbol table ops
7012 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
7013 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
7014 SV *sym = sv_2mortal(
7015 newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0));
7016 sv_catpvn(sym, "::", 2);
7022 OP *o = newOP(OP_PADSV, 0);
7024 PL_lex_op = readline_overriden
7025 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
7026 append_elem(OP_LIST, o,
7027 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
7028 : (OP*)newUNOP(OP_READLINE, 0, o);
7037 ? (GV_ADDMULTI | GV_ADDINEVAL)
7040 PL_lex_op = readline_overriden
7041 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
7042 append_elem(OP_LIST,
7043 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
7044 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
7045 : (OP*)newUNOP(OP_READLINE, 0,
7046 newUNOP(OP_RV2SV, 0,
7047 newGVOP(OP_GV, 0, gv)));
7049 if (!readline_overriden)
7050 PL_lex_op->op_flags |= OPf_SPECIAL;
7051 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
7052 yylval.ival = OP_NULL;
7055 /* If it's none of the above, it must be a literal filehandle
7056 (<Foo::BAR> or <FOO>) so build a simple readline OP */
7058 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
7059 PL_lex_op = readline_overriden
7060 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
7061 append_elem(OP_LIST,
7062 newGVOP(OP_GV, 0, gv),
7063 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
7064 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
7065 yylval.ival = OP_NULL;
7074 takes: start position in buffer
7075 keep_quoted preserve \ on the embedded delimiter(s)
7076 keep_delims preserve the delimiters around the string
7077 returns: position to continue reading from buffer
7078 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
7079 updates the read buffer.
7081 This subroutine pulls a string out of the input. It is called for:
7082 q single quotes q(literal text)
7083 ' single quotes 'literal text'
7084 qq double quotes qq(interpolate $here please)
7085 " double quotes "interpolate $here please"
7086 qx backticks qx(/bin/ls -l)
7087 ` backticks `/bin/ls -l`
7088 qw quote words @EXPORT_OK = qw( func() $spam )
7089 m// regexp match m/this/
7090 s/// regexp substitute s/this/that/
7091 tr/// string transliterate tr/this/that/
7092 y/// string transliterate y/this/that/
7093 ($*@) sub prototypes sub foo ($)
7094 (stuff) sub attr parameters sub foo : attr(stuff)
7095 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
7097 In most of these cases (all but <>, patterns and transliterate)
7098 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
7099 calls scan_str(). s/// makes yylex() call scan_subst() which calls
7100 scan_str(). tr/// and y/// make yylex() call scan_trans() which
7103 It skips whitespace before the string starts, and treats the first
7104 character as the delimiter. If the delimiter is one of ([{< then
7105 the corresponding "close" character )]}> is used as the closing
7106 delimiter. It allows quoting of delimiters, and if the string has
7107 balanced delimiters ([{<>}]) it allows nesting.
7109 On success, the SV with the resulting string is put into lex_stuff or,
7110 if that is already non-NULL, into lex_repl. The second case occurs only
7111 when parsing the RHS of the special constructs s/// and tr/// (y///).
7112 For convenience, the terminating delimiter character is stuffed into
7117 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
7119 SV *sv; /* scalar value: string */
7120 char *tmps; /* temp string, used for delimiter matching */
7121 register char *s = start; /* current position in the buffer */
7122 register char term; /* terminating character */
7123 register char *to; /* current position in the sv's data */
7124 I32 brackets = 1; /* bracket nesting level */
7125 bool has_utf8 = FALSE; /* is there any utf8 content? */
7126 I32 termcode; /* terminating char. code */
7127 U8 termstr[UTF8_MAXLEN]; /* terminating string */
7128 STRLEN termlen; /* length of terminating string */
7129 char *last = NULL; /* last position for nesting bracket */
7131 /* skip space before the delimiter */
7135 /* mark where we are, in case we need to report errors */
7138 /* after skipping whitespace, the next character is the terminator */
7141 termcode = termstr[0] = term;
7145 termcode = utf8_to_uvchr((U8*)s, &termlen);
7146 Copy(s, termstr, termlen, U8);
7147 if (!UTF8_IS_INVARIANT(term))
7151 /* mark where we are */
7152 PL_multi_start = CopLINE(PL_curcop);
7153 PL_multi_open = term;
7155 /* find corresponding closing delimiter */
7156 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
7157 termcode = termstr[0] = term = tmps[5];
7159 PL_multi_close = term;
7161 /* create a new SV to hold the contents. 87 is leak category, I'm
7162 assuming. 79 is the SV's initial length. What a random number. */
7164 sv_upgrade(sv, SVt_PVIV);
7165 SvIVX(sv) = termcode;
7166 (void)SvPOK_only(sv); /* validate pointer */
7168 /* move past delimiter and try to read a complete string */
7170 sv_catpvn(sv, s, termlen);
7173 if (PL_encoding && !UTF) {
7177 int offset = s - SvPVX(PL_linestr);
7178 bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
7179 &offset, (char*)termstr, termlen);
7180 char *ns = SvPVX(PL_linestr) + offset;
7181 char *svlast = SvEND(sv) - 1;
7183 for (; s < ns; s++) {
7184 if (*s == '\n' && !PL_rsfp)
7185 CopLINE_inc(PL_curcop);
7188 goto read_more_line;
7190 /* handle quoted delimiters */
7191 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
7193 for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';)
7195 if ((svlast-1 - t) % 2) {
7199 SvCUR_set(sv, SvCUR(sv) - 1);
7204 if (PL_multi_open == PL_multi_close) {
7211 for (w = t = last; t < svlast; w++, t++) {
7212 /* At here, all closes are "was quoted" one,
7213 so we don't check PL_multi_close. */
7215 if (!keep_quoted && *(t+1) == PL_multi_open)
7220 else if (*t == PL_multi_open)
7228 SvCUR_set(sv, w - SvPVX(sv));
7231 if (--brackets <= 0)
7237 SvCUR_set(sv, SvCUR(sv) - 1);
7243 /* extend sv if need be */
7244 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
7245 /* set 'to' to the next character in the sv's string */
7246 to = SvPVX(sv)+SvCUR(sv);
7248 /* if open delimiter is the close delimiter read unbridle */
7249 if (PL_multi_open == PL_multi_close) {
7250 for (; s < PL_bufend; s++,to++) {
7251 /* embedded newlines increment the current line number */
7252 if (*s == '\n' && !PL_rsfp)
7253 CopLINE_inc(PL_curcop);
7254 /* handle quoted delimiters */
7255 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
7256 if (!keep_quoted && s[1] == term)
7258 /* any other quotes are simply copied straight through */
7262 /* terminate when run out of buffer (the for() condition), or
7263 have found the terminator */
7264 else if (*s == term) {
7267 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
7270 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7276 /* if the terminator isn't the same as the start character (e.g.,
7277 matched brackets), we have to allow more in the quoting, and
7278 be prepared for nested brackets.
7281 /* read until we run out of string, or we find the terminator */
7282 for (; s < PL_bufend; s++,to++) {
7283 /* embedded newlines increment the line count */
7284 if (*s == '\n' && !PL_rsfp)
7285 CopLINE_inc(PL_curcop);
7286 /* backslashes can escape the open or closing characters */
7287 if (*s == '\\' && s+1 < PL_bufend) {
7289 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
7294 /* allow nested opens and closes */
7295 else if (*s == PL_multi_close && --brackets <= 0)
7297 else if (*s == PL_multi_open)
7299 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7304 /* terminate the copied string and update the sv's end-of-string */
7306 SvCUR_set(sv, to - SvPVX(sv));
7309 * this next chunk reads more into the buffer if we're not done yet
7313 break; /* handle case where we are done yet :-) */
7315 #ifndef PERL_STRICT_CR
7316 if (to - SvPVX(sv) >= 2) {
7317 if ((to[-2] == '\r' && to[-1] == '\n') ||
7318 (to[-2] == '\n' && to[-1] == '\r'))
7322 SvCUR_set(sv, to - SvPVX(sv));
7324 else if (to[-1] == '\r')
7327 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
7332 /* if we're out of file, or a read fails, bail and reset the current
7333 line marker so we can report where the unterminated string began
7336 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
7338 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
7341 /* we read a line, so increment our line counter */
7342 CopLINE_inc(PL_curcop);
7344 /* update debugger info */
7345 if (PERLDB_LINE && PL_curstash != PL_debstash) {
7346 SV *sv = NEWSV(88,0);
7348 sv_upgrade(sv, SVt_PVMG);
7349 sv_setsv(sv,PL_linestr);
7352 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
7355 /* having changed the buffer, we must update PL_bufend */
7356 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7357 PL_last_lop = PL_last_uni = Nullch;
7360 /* at this point, we have successfully read the delimited string */
7362 if (!PL_encoding || UTF) {
7364 sv_catpvn(sv, s, termlen);
7367 if (has_utf8 || PL_encoding)
7370 PL_multi_end = CopLINE(PL_curcop);
7372 /* if we allocated too much space, give some back */
7373 if (SvCUR(sv) + 5 < SvLEN(sv)) {
7374 SvLEN_set(sv, SvCUR(sv) + 1);
7375 Renew(SvPVX(sv), SvLEN(sv), char);
7378 /* decide whether this is the first or second quoted string we've read
7391 takes: pointer to position in buffer
7392 returns: pointer to new position in buffer
7393 side-effects: builds ops for the constant in yylval.op
7395 Read a number in any of the formats that Perl accepts:
7397 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
7398 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
7401 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
7403 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
7406 If it reads a number without a decimal point or an exponent, it will
7407 try converting the number to an integer and see if it can do so
7408 without loss of precision.
7412 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
7414 register char *s = start; /* current position in buffer */
7415 register char *d; /* destination in temp buffer */
7416 register char *e; /* end of temp buffer */
7417 NV nv; /* number read, as a double */
7418 SV *sv = Nullsv; /* place to put the converted number */
7419 bool floatit; /* boolean: int or float? */
7420 char *lastub = 0; /* position of last underbar */
7421 static char number_too_long[] = "Number too long";
7423 /* We use the first character to decide what type of number this is */
7427 Perl_croak(aTHX_ "panic: scan_num");
7429 /* if it starts with a 0, it could be an octal number, a decimal in
7430 0.13 disguise, or a hexadecimal number, or a binary number. */
7434 u holds the "number so far"
7435 shift the power of 2 of the base
7436 (hex == 4, octal == 3, binary == 1)
7437 overflowed was the number more than we can hold?
7439 Shift is used when we add a digit. It also serves as an "are
7440 we in octal/hex/binary?" indicator to disallow hex characters
7446 bool overflowed = FALSE;
7447 bool just_zero = TRUE; /* just plain 0 or binary number? */
7448 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7449 static char* bases[5] = { "", "binary", "", "octal",
7451 static char* Bases[5] = { "", "Binary", "", "Octal",
7453 static char *maxima[5] = { "",
7454 "0b11111111111111111111111111111111",
7458 char *base, *Base, *max;
7465 } else if (s[1] == 'b') {
7470 /* check for a decimal in disguise */
7471 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7473 /* so it must be octal */
7480 if (ckWARN(WARN_SYNTAX))
7481 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7482 "Misplaced _ in number");
7486 base = bases[shift];
7487 Base = Bases[shift];
7488 max = maxima[shift];
7490 /* read the rest of the number */
7492 /* x is used in the overflow test,
7493 b is the digit we're adding on. */
7498 /* if we don't mention it, we're done */
7502 /* _ are ignored -- but warned about if consecutive */
7504 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7505 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7506 "Misplaced _ in number");
7510 /* 8 and 9 are not octal */
7513 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7517 case '2': case '3': case '4':
7518 case '5': case '6': case '7':
7520 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7524 b = *s++ & 15; /* ASCII digit -> value of digit */
7528 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7529 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7530 /* make sure they said 0x */
7535 /* Prepare to put the digit we have onto the end
7536 of the number so far. We check for overflows.
7542 x = u << shift; /* make room for the digit */
7544 if ((x >> shift) != u
7545 && !(PL_hints & HINT_NEW_BINARY)) {
7548 if (ckWARN_d(WARN_OVERFLOW))
7549 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
7550 "Integer overflow in %s number",
7553 u = x | b; /* add the digit to the end */
7556 n *= nvshift[shift];
7557 /* If an NV has not enough bits in its
7558 * mantissa to represent an UV this summing of
7559 * small low-order numbers is a waste of time
7560 * (because the NV cannot preserve the
7561 * low-order bits anyway): we could just
7562 * remember when did we overflow and in the
7563 * end just multiply n by the right
7571 /* if we get here, we had success: make a scalar value from
7576 /* final misplaced underbar check */
7578 if (ckWARN(WARN_SYNTAX))
7579 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7584 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7585 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7586 "%s number > %s non-portable",
7592 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7593 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7594 "%s number > %s non-portable",
7599 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
7600 sv = new_constant(start, s - start, "integer",
7602 else if (PL_hints & HINT_NEW_BINARY)
7603 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7608 handle decimal numbers.
7609 we're also sent here when we read a 0 as the first digit
7611 case '1': case '2': case '3': case '4': case '5':
7612 case '6': case '7': case '8': case '9': case '.':
7615 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7618 /* read next group of digits and _ and copy into d */
7619 while (isDIGIT(*s) || *s == '_') {
7620 /* skip underscores, checking for misplaced ones
7624 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7625 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7626 "Misplaced _ in number");
7630 /* check for end of fixed-length buffer */
7632 Perl_croak(aTHX_ number_too_long);
7633 /* if we're ok, copy the character */
7638 /* final misplaced underbar check */
7639 if (lastub && s == lastub + 1) {
7640 if (ckWARN(WARN_SYNTAX))
7641 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7644 /* read a decimal portion if there is one. avoid
7645 3..5 being interpreted as the number 3. followed
7648 if (*s == '.' && s[1] != '.') {
7653 if (ckWARN(WARN_SYNTAX))
7654 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7655 "Misplaced _ in number");
7659 /* copy, ignoring underbars, until we run out of digits.
7661 for (; isDIGIT(*s) || *s == '_'; s++) {
7662 /* fixed length buffer check */
7664 Perl_croak(aTHX_ number_too_long);
7666 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7667 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7668 "Misplaced _ in number");
7674 /* fractional part ending in underbar? */
7676 if (ckWARN(WARN_SYNTAX))
7677 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7678 "Misplaced _ in number");
7680 if (*s == '.' && isDIGIT(s[1])) {
7681 /* oops, it's really a v-string, but without the "v" */
7687 /* read exponent part, if present */
7688 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
7692 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7693 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
7695 /* stray preinitial _ */
7697 if (ckWARN(WARN_SYNTAX))
7698 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7699 "Misplaced _ in number");
7703 /* allow positive or negative exponent */
7704 if (*s == '+' || *s == '-')
7707 /* stray initial _ */
7709 if (ckWARN(WARN_SYNTAX))
7710 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7711 "Misplaced _ in number");
7715 /* read digits of exponent */
7716 while (isDIGIT(*s) || *s == '_') {
7719 Perl_croak(aTHX_ number_too_long);
7723 if (ckWARN(WARN_SYNTAX) &&
7724 ((lastub && s == lastub + 1) ||
7725 (!isDIGIT(s[1]) && s[1] != '_')))
7726 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7727 "Misplaced _ in number");
7734 /* make an sv from the string */
7738 We try to do an integer conversion first if no characters
7739 indicating "float" have been found.
7744 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7746 if (flags == IS_NUMBER_IN_UV) {
7748 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7751 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7752 if (uv <= (UV) IV_MIN)
7753 sv_setiv(sv, -(IV)uv);
7760 /* terminate the string */
7762 nv = Atof(PL_tokenbuf);
7766 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7767 (PL_hints & HINT_NEW_INTEGER) )
7768 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7769 (floatit ? "float" : "integer"),
7773 /* if it starts with a v, it could be a v-string */
7776 sv = NEWSV(92,5); /* preallocate storage space */
7777 s = scan_vstring(s,sv);
7781 /* make the op for the constant and return */
7784 lvalp->opval = newSVOP(OP_CONST, 0, sv);
7786 lvalp->opval = Nullop;
7792 S_scan_formline(pTHX_ register char *s)
7796 SV *stuff = newSVpvn("",0);
7797 bool needargs = FALSE;
7803 #ifdef PERL_STRICT_CR
7804 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7806 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7808 if (*t == '\n' || t == PL_bufend) {
7813 if (PL_in_eval && !PL_rsfp) {
7814 eol = memchr(s,'\n',PL_bufend-s);
7819 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7821 for (t = s; t < eol; t++) {
7822 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7824 goto enough; /* ~~ must be first line in formline */
7826 if (*t == '@' || *t == '^')
7830 sv_catpvn(stuff, s, eol-s);
7831 #ifndef PERL_STRICT_CR
7832 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7833 char *end = SvPVX(stuff) + SvCUR(stuff);
7845 s = filter_gets(PL_linestr, PL_rsfp, 0);
7846 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7847 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7848 PL_last_lop = PL_last_uni = Nullch;
7860 PL_lex_state = LEX_NORMAL;
7861 PL_nextval[PL_nexttoke].ival = 0;
7865 PL_lex_state = LEX_FORMLINE;
7867 if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff)))
7869 else if (PL_encoding)
7870 sv_recode_to_utf8(stuff, PL_encoding);
7872 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7874 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7878 SvREFCNT_dec(stuff);
7880 PL_lex_formbrack = 0;
7891 PL_cshlen = strlen(PL_cshname);
7896 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7898 I32 oldsavestack_ix = PL_savestack_ix;
7899 CV* outsidecv = PL_compcv;
7902 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7904 SAVEI32(PL_subline);
7905 save_item(PL_subname);
7906 SAVESPTR(PL_compcv);
7908 PL_compcv = (CV*)NEWSV(1104,0);
7909 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7910 CvFLAGS(PL_compcv) |= flags;
7912 PL_subline = CopLINE(PL_curcop);
7913 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
7914 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7915 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
7917 return oldsavestack_ix;
7921 #pragma segment Perl_yylex
7924 Perl_yywarn(pTHX_ char *s)
7926 PL_in_eval |= EVAL_WARNONLY;
7928 PL_in_eval &= ~EVAL_WARNONLY;
7933 Perl_yyerror(pTHX_ char *s)
7936 char *context = NULL;
7940 if (!yychar || (yychar == ';' && !PL_rsfp))
7942 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7943 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7946 The code below is removed for NetWare because it abends/crashes on NetWare
7947 when the script has error such as not having the closing quotes like:
7949 Checking of white spaces is anyway done in NetWare code.
7952 while (isSPACE(*PL_oldoldbufptr))
7955 context = PL_oldoldbufptr;
7956 contlen = PL_bufptr - PL_oldoldbufptr;
7958 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7959 PL_oldbufptr != PL_bufptr) {
7962 The code below is removed for NetWare because it abends/crashes on NetWare
7963 when the script has error such as not having the closing quotes like:
7965 Checking of white spaces is anyway done in NetWare code.
7968 while (isSPACE(*PL_oldbufptr))
7971 context = PL_oldbufptr;
7972 contlen = PL_bufptr - PL_oldbufptr;
7974 else if (yychar > 255)
7975 where = "next token ???";
7976 else if (yychar == -2) { /* YYEMPTY */
7977 if (PL_lex_state == LEX_NORMAL ||
7978 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7979 where = "at end of line";
7980 else if (PL_lex_inpat)
7981 where = "within pattern";
7983 where = "within string";
7986 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7988 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7989 else if (isPRINT_LC(yychar))
7990 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7992 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7993 where = SvPVX(where_sv);
7995 msg = sv_2mortal(newSVpv(s, 0));
7996 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7997 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7999 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
8001 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
8002 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
8003 Perl_sv_catpvf(aTHX_ msg,
8004 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
8005 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
8008 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
8009 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
8012 if (PL_error_count >= 10) {
8013 if (PL_in_eval && SvCUR(ERRSV))
8014 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
8015 ERRSV, OutCopFILE(PL_curcop));
8017 Perl_croak(aTHX_ "%s has too many errors.\n",
8018 OutCopFILE(PL_curcop));
8021 PL_in_my_stash = Nullhv;
8025 #pragma segment Main
8029 S_swallow_bom(pTHX_ U8 *s)
8032 slen = SvCUR(PL_linestr);
8036 /* UTF-16 little-endian? (or UTF32-LE?) */
8037 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
8038 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
8039 #ifndef PERL_NO_UTF16_FILTER
8040 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
8043 if (PL_bufend > (char*)s) {
8047 filter_add(utf16rev_textfilter, NULL);
8048 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
8049 utf16_to_utf8_reversed(s, news,
8050 PL_bufend - (char*)s - 1,
8052 sv_setpvn(PL_linestr, (const char*)news, newlen);
8054 SvUTF8_on(PL_linestr);
8055 s = (U8*)SvPVX(PL_linestr);
8056 PL_bufend = SvPVX(PL_linestr) + newlen;
8059 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
8064 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
8065 #ifndef PERL_NO_UTF16_FILTER
8066 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
8069 if (PL_bufend > (char *)s) {
8073 filter_add(utf16_textfilter, NULL);
8074 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
8075 utf16_to_utf8(s, news,
8076 PL_bufend - (char*)s,
8078 sv_setpvn(PL_linestr, (const char*)news, newlen);
8080 SvUTF8_on(PL_linestr);
8081 s = (U8*)SvPVX(PL_linestr);
8082 PL_bufend = SvPVX(PL_linestr) + newlen;
8085 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
8090 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
8091 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
8098 if (s[2] == 0xFE && s[3] == 0xFF) {
8099 /* UTF-32 big-endian */
8100 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
8103 else if (s[2] == 0 && s[3] != 0) {
8106 * are a good indicator of UTF-16BE. */
8107 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
8112 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
8115 * are a good indicator of UTF-16LE. */
8116 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
8125 * Restore a source filter.
8129 restore_rsfp(pTHX_ void *f)
8131 PerlIO *fp = (PerlIO*)f;
8133 if (PL_rsfp == PerlIO_stdin())
8134 PerlIO_clearerr(PL_rsfp);
8135 else if (PL_rsfp && (PL_rsfp != fp))
8136 PerlIO_close(PL_rsfp);
8140 #ifndef PERL_NO_UTF16_FILTER
8142 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
8144 STRLEN old = SvCUR(sv);
8145 I32 count = FILTER_READ(idx+1, sv, maxlen);
8146 DEBUG_P(PerlIO_printf(Perl_debug_log,
8147 "utf16_textfilter(%p): %d %d (%d)\n",
8148 utf16_textfilter, idx, maxlen, count));
8152 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
8153 Copy(SvPVX(sv), tmps, old, char);
8154 utf16_to_utf8((U8*)SvPVX(sv) + old, tmps + old,
8155 SvCUR(sv) - old, &newlen);
8156 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
8158 DEBUG_P({sv_dump(sv);});
8163 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
8165 STRLEN old = SvCUR(sv);
8166 I32 count = FILTER_READ(idx+1, sv, maxlen);
8167 DEBUG_P(PerlIO_printf(Perl_debug_log,
8168 "utf16rev_textfilter(%p): %d %d (%d)\n",
8169 utf16rev_textfilter, idx, maxlen, count));
8173 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
8174 Copy(SvPVX(sv), tmps, old, char);
8175 utf16_to_utf8((U8*)SvPVX(sv) + old, tmps + old,
8176 SvCUR(sv) - old, &newlen);
8177 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
8179 DEBUG_P({ sv_dump(sv); });
8185 Returns a pointer to the next character after the parsed
8186 vstring, as well as updating the passed in sv.
8188 Function must be called like
8191 s = scan_vstring(s,sv);
8193 The sv should already be large enough to store the vstring
8194 passed in, for performance reasons.
8199 Perl_scan_vstring(pTHX_ char *s, SV *sv)
8203 if (*pos == 'v') pos++; /* get past 'v' */
8204 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
8207 /* this may not be a v-string if followed by => */
8209 while (next < PL_bufend && isSPACE(*next))
8211 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
8212 /* return string not v-string */
8213 sv_setpvn(sv,(char *)s,pos-s);
8218 if (!isALPHA(*pos)) {
8220 U8 tmpbuf[UTF8_MAXLEN+1];
8223 if (*s == 'v') s++; /* get past 'v' */
8225 sv_setpvn(sv, "", 0);
8230 /* this is atoi() that tolerates underscores */
8233 while (--end >= s) {
8238 rev += (*end - '0') * mult;
8240 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
8241 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
8242 "Integer overflow in decimal number");
8246 if (rev > 0x7FFFFFFF)
8247 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
8249 /* Append native character for the rev point */
8250 tmpend = uvchr_to_utf8(tmpbuf, rev);
8251 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
8252 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
8254 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
8260 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
8264 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);