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 = newSVpvn("<== ", 4);
280 for (p = debug_tokens; p->token; p++) {
281 if (p->token == (int)rv) {
288 Perl_sv_catpv(aTHX_ report, name);
289 else if ((char)rv > ' ' && (char)rv < '~')
290 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
292 Perl_sv_catpv(aTHX_ report, "EOF");
294 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
297 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
300 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", yylval.ival);
302 case TOKENTYPE_OPNUM:
303 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
304 PL_op_name[yylval.ival]);
307 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
309 case TOKENTYPE_OPVAL:
311 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
312 PL_op_name[yylval.opval->op_type]);
314 Perl_sv_catpv(aTHX_ report, "(opval=null)");
317 Perl_sv_catpvf(aTHX_ report, " at line %d [", CopLINE(PL_curcop));
318 if (s - PL_bufptr > 0)
319 sv_catpvn(report, PL_bufptr, s - PL_bufptr);
321 if (PL_oldbufptr && *PL_oldbufptr)
322 sv_catpv(report, PL_tokenbuf);
324 PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen(report));
334 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
335 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
339 S_ao(pTHX_ int toketype)
341 if (*PL_bufptr == '=') {
343 if (toketype == ANDAND)
344 yylval.ival = OP_ANDASSIGN;
345 else if (toketype == OROR)
346 yylval.ival = OP_ORASSIGN;
347 else if (toketype == DORDOR)
348 yylval.ival = OP_DORASSIGN;
356 * When Perl expects an operator and finds something else, no_op
357 * prints the warning. It always prints "<something> found where
358 * operator expected. It prints "Missing semicolon on previous line?"
359 * if the surprise occurs at the start of the line. "do you need to
360 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
361 * where the compiler doesn't know if foo is a method call or a function.
362 * It prints "Missing operator before end of line" if there's nothing
363 * after the missing operator, or "... before <...>" if there is something
364 * after the missing operator.
368 S_no_op(pTHX_ char *what, char *s)
370 char *oldbp = PL_bufptr;
371 bool is_first = (PL_oldbufptr == PL_linestart);
377 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
378 if (ckWARN_d(WARN_SYNTAX)) {
380 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
381 "\t(Missing semicolon on previous line?)\n");
382 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
384 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
385 if (t < PL_bufptr && isSPACE(*t))
386 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
387 "\t(Do you need to predeclare %.*s?)\n",
388 t - PL_oldoldbufptr, PL_oldoldbufptr);
392 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
393 "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
401 * Complain about missing quote/regexp/heredoc terminator.
402 * If it's called with (char *)NULL then it cauterizes the line buffer.
403 * If we're in a delimited string and the delimiter is a control
404 * character, it's reformatted into a two-char sequence like ^C.
409 S_missingterm(pTHX_ char *s)
414 char *nl = strrchr(s,'\n');
420 iscntrl(PL_multi_close)
422 PL_multi_close < 32 || PL_multi_close == 127
426 tmpbuf[1] = toCTRL(PL_multi_close);
431 *tmpbuf = (char)PL_multi_close;
435 q = strchr(s,'"') ? '\'' : '"';
436 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
444 Perl_deprecate(pTHX_ char *s)
446 if (ckWARN(WARN_DEPRECATED))
447 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
451 Perl_deprecate_old(pTHX_ char *s)
453 /* This function should NOT be called for any new deprecated warnings */
454 /* Use Perl_deprecate instead */
456 /* It is here to maintain backward compatibility with the pre-5.8 */
457 /* warnings category hierarchy. The "deprecated" category used to */
458 /* live under the "syntax" category. It is now a top-level category */
459 /* in its own right. */
461 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
462 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
463 "Use of %s is deprecated", s);
468 * Deprecate a comma-less variable list.
474 deprecate_old("comma-less variable list");
478 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
479 * utf16-to-utf8-reversed.
482 #ifdef PERL_CR_FILTER
486 register char *s = SvPVX(sv);
487 register char *e = s + SvCUR(sv);
488 /* outer loop optimized to do nothing if there are no CR-LFs */
490 if (*s++ == '\r' && *s == '\n') {
491 /* hit a CR-LF, need to copy the rest */
492 register char *d = s - 1;
495 if (*s == '\r' && s[1] == '\n')
506 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
508 I32 count = FILTER_READ(idx+1, sv, maxlen);
509 if (count > 0 && !maxlen)
517 * Initialize variables. Uses the Perl save_stack to save its state (for
518 * recursive calls to the parser).
522 Perl_lex_start(pTHX_ SV *line)
527 SAVEI32(PL_lex_dojoin);
528 SAVEI32(PL_lex_brackets);
529 SAVEI32(PL_lex_casemods);
530 SAVEI32(PL_lex_starts);
531 SAVEI32(PL_lex_state);
532 SAVEVPTR(PL_lex_inpat);
533 SAVEI32(PL_lex_inwhat);
534 if (PL_lex_state == LEX_KNOWNEXT) {
535 I32 toke = PL_nexttoke;
536 while (--toke >= 0) {
537 SAVEI32(PL_nexttype[toke]);
538 SAVEVPTR(PL_nextval[toke]);
540 SAVEI32(PL_nexttoke);
542 SAVECOPLINE(PL_curcop);
545 SAVEPPTR(PL_oldbufptr);
546 SAVEPPTR(PL_oldoldbufptr);
547 SAVEPPTR(PL_last_lop);
548 SAVEPPTR(PL_last_uni);
549 SAVEPPTR(PL_linestart);
550 SAVESPTR(PL_linestr);
551 SAVEGENERICPV(PL_lex_brackstack);
552 SAVEGENERICPV(PL_lex_casestack);
553 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
554 SAVESPTR(PL_lex_stuff);
555 SAVEI32(PL_lex_defer);
556 SAVEI32(PL_sublex_info.sub_inwhat);
557 SAVESPTR(PL_lex_repl);
559 SAVEINT(PL_lex_expect);
561 PL_lex_state = LEX_NORMAL;
565 New(899, PL_lex_brackstack, 120, char);
566 New(899, PL_lex_casestack, 12, char);
568 *PL_lex_casestack = '\0';
571 PL_lex_stuff = Nullsv;
572 PL_lex_repl = Nullsv;
576 PL_sublex_info.sub_inwhat = 0;
578 if (SvREADONLY(PL_linestr))
579 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
580 s = SvPV(PL_linestr, len);
581 if (!len || s[len-1] != ';') {
582 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
583 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
584 sv_catpvn(PL_linestr, "\n;", 2);
586 SvTEMP_off(PL_linestr);
587 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
588 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
589 PL_last_lop = PL_last_uni = Nullch;
595 * Finalizer for lexing operations. Must be called when the parser is
596 * done with the lexer.
602 PL_doextract = FALSE;
607 * This subroutine has nothing to do with tilting, whether at windmills
608 * or pinball tables. Its name is short for "increment line". It
609 * increments the current line number in CopLINE(PL_curcop) and checks
610 * to see whether the line starts with a comment of the form
611 * # line 500 "foo.pm"
612 * If so, it sets the current line number and file to the values in the comment.
616 S_incline(pTHX_ char *s)
623 CopLINE_inc(PL_curcop);
626 while (SPACE_OR_TAB(*s)) s++;
627 if (strnEQ(s, "line", 4))
631 if (SPACE_OR_TAB(*s))
635 while (SPACE_OR_TAB(*s)) s++;
641 while (SPACE_OR_TAB(*s))
643 if (*s == '"' && (t = strchr(s+1, '"'))) {
648 for (t = s; !isSPACE(*t); t++) ;
651 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
653 if (*e != '\n' && *e != '\0')
654 return; /* false alarm */
659 CopFILE_free(PL_curcop);
660 CopFILE_set(PL_curcop, s);
663 CopLINE_set(PL_curcop, atoi(n)-1);
668 * Called to gobble the appropriate amount and type of whitespace.
669 * Skips comments as well.
673 S_skipspace(pTHX_ register char *s)
675 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
676 while (s < PL_bufend && SPACE_OR_TAB(*s))
682 SSize_t oldprevlen, oldoldprevlen;
683 SSize_t oldloplen = 0, oldunilen = 0;
684 while (s < PL_bufend && isSPACE(*s)) {
685 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
690 if (s < PL_bufend && *s == '#') {
691 while (s < PL_bufend && *s != '\n')
695 if (PL_in_eval && !PL_rsfp) {
702 /* only continue to recharge the buffer if we're at the end
703 * of the buffer, we're not reading from a source filter, and
704 * we're in normal lexing mode
706 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
707 PL_lex_state == LEX_FORMLINE)
710 /* try to recharge the buffer */
711 if ((s = filter_gets(PL_linestr, PL_rsfp,
712 (prevlen = SvCUR(PL_linestr)))) == Nullch)
714 /* end of file. Add on the -p or -n magic */
717 ";}continue{print or die qq(-p destination: $!\\n);}");
718 PL_minus_n = PL_minus_p = 0;
720 else if (PL_minus_n) {
721 sv_setpvn(PL_linestr, ";}", 2);
725 sv_setpvn(PL_linestr,";", 1);
727 /* reset variables for next time we lex */
728 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
730 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
731 PL_last_lop = PL_last_uni = Nullch;
733 /* Close the filehandle. Could be from -P preprocessor,
734 * STDIN, or a regular file. If we were reading code from
735 * STDIN (because the commandline held no -e or filename)
736 * then we don't close it, we reset it so the code can
737 * read from STDIN too.
740 if (PL_preprocess && !PL_in_eval)
741 (void)PerlProc_pclose(PL_rsfp);
742 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
743 PerlIO_clearerr(PL_rsfp);
745 (void)PerlIO_close(PL_rsfp);
750 /* not at end of file, so we only read another line */
751 /* make corresponding updates to old pointers, for yyerror() */
752 oldprevlen = PL_oldbufptr - PL_bufend;
753 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
755 oldunilen = PL_last_uni - PL_bufend;
757 oldloplen = PL_last_lop - PL_bufend;
758 PL_linestart = PL_bufptr = s + prevlen;
759 PL_bufend = s + SvCUR(PL_linestr);
761 PL_oldbufptr = s + oldprevlen;
762 PL_oldoldbufptr = s + oldoldprevlen;
764 PL_last_uni = s + oldunilen;
766 PL_last_lop = s + oldloplen;
769 /* debugger active and we're not compiling the debugger code,
770 * so store the line into the debugger's array of lines
772 if (PERLDB_LINE && PL_curstash != PL_debstash) {
773 SV *sv = NEWSV(85,0);
775 sv_upgrade(sv, SVt_PVMG);
776 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
779 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
786 * Check the unary operators to ensure there's no ambiguity in how they're
787 * used. An ambiguous piece of code would be:
789 * This doesn't mean rand() + 5. Because rand() is a unary operator,
790 * the +5 is its argument.
799 if (PL_oldoldbufptr != PL_last_uni)
801 while (isSPACE(*PL_last_uni))
803 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
804 if ((t = strchr(s, '(')) && t < PL_bufptr)
806 if (ckWARN_d(WARN_AMBIGUOUS)){
809 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
810 "Warning: Use of \"%s\" without parentheses is ambiguous",
817 * LOP : macro to build a list operator. Its behaviour has been replaced
818 * with a subroutine, S_lop() for which LOP is just another name.
821 #define LOP(f,x) return lop(f,x,s)
825 * Build a list operator (or something that might be one). The rules:
826 * - if we have a next token, then it's a list operator [why?]
827 * - if the next thing is an opening paren, then it's a function
828 * - else it's a list operator
832 S_lop(pTHX_ I32 f, int x, char *s)
838 PL_last_lop = PL_oldbufptr;
839 PL_last_lop_op = (OPCODE)f;
841 return REPORT(LSTOP);
848 return REPORT(LSTOP);
853 * When the lexer realizes it knows the next token (for instance,
854 * it is reordering tokens for the parser) then it can call S_force_next
855 * to know what token to return the next time the lexer is called. Caller
856 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
857 * handles the token correctly.
861 S_force_next(pTHX_ I32 type)
863 PL_nexttype[PL_nexttoke] = type;
865 if (PL_lex_state != LEX_KNOWNEXT) {
866 PL_lex_defer = PL_lex_state;
867 PL_lex_expect = PL_expect;
868 PL_lex_state = LEX_KNOWNEXT;
873 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
875 SV *sv = newSVpvn(start,len);
876 if (UTF && !IN_BYTES && is_utf8_string((U8*)start, len))
883 * When the lexer knows the next thing is a word (for instance, it has
884 * just seen -> and it knows that the next char is a word char, then
885 * it calls S_force_word to stick the next word into the PL_next lookahead.
888 * char *start : buffer position (must be within PL_linestr)
889 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
890 * int check_keyword : if true, Perl checks to make sure the word isn't
891 * a keyword (do this if the word is a label, e.g. goto FOO)
892 * int allow_pack : if true, : characters will also be allowed (require,
894 * int allow_initial_tick : used by the "sub" lexer only.
898 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
903 start = skipspace(start);
905 if (isIDFIRST_lazy_if(s,UTF) ||
906 (allow_pack && *s == ':') ||
907 (allow_initial_tick && *s == '\'') )
909 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
910 if (check_keyword && keyword(PL_tokenbuf, len))
912 if (token == METHOD) {
917 PL_expect = XOPERATOR;
920 PL_nextval[PL_nexttoke].opval
921 = (OP*)newSVOP(OP_CONST,0,
922 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
923 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
931 * Called when the lexer wants $foo *foo &foo etc, but the program
932 * text only contains the "foo" portion. The first argument is a pointer
933 * to the "foo", and the second argument is the type symbol to prefix.
934 * Forces the next token to be a "WORD".
935 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
939 S_force_ident(pTHX_ register char *s, int kind)
942 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
943 PL_nextval[PL_nexttoke].opval = o;
946 o->op_private = OPpCONST_ENTERED;
947 /* XXX see note in pp_entereval() for why we forgo typo
948 warnings if the symbol must be introduced in an eval.
950 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
951 kind == '$' ? SVt_PV :
952 kind == '@' ? SVt_PVAV :
953 kind == '%' ? SVt_PVHV :
961 Perl_str_to_version(pTHX_ SV *sv)
966 char *start = SvPVx(sv,len);
967 bool utf = SvUTF8(sv) ? TRUE : FALSE;
968 char *end = start + len;
969 while (start < end) {
973 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
978 retval += ((NV)n)/nshift;
987 * Forces the next token to be a version number.
988 * If the next token appears to be an invalid version number, (e.g. "v2b"),
989 * and if "guessing" is TRUE, then no new token is created (and the caller
990 * must use an alternative parsing method).
994 S_force_version(pTHX_ char *s, int guessing)
996 OP *version = Nullop;
1005 while (isDIGIT(*d) || *d == '_' || *d == '.')
1007 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1009 s = scan_num(s, &yylval);
1010 version = yylval.opval;
1011 ver = cSVOPx(version)->op_sv;
1012 if (SvPOK(ver) && !SvNIOK(ver)) {
1013 (void)SvUPGRADE(ver, SVt_PVNV);
1014 SvNVX(ver) = str_to_version(ver);
1015 SvNOK_on(ver); /* hint that it is a version */
1022 /* NOTE: The parser sees the package name and the VERSION swapped */
1023 PL_nextval[PL_nexttoke].opval = version;
1031 * Tokenize a quoted string passed in as an SV. It finds the next
1032 * chunk, up to end of string or a backslash. It may make a new
1033 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1038 S_tokeq(pTHX_ SV *sv)
1041 register char *send;
1049 s = SvPV_force(sv, len);
1050 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1053 while (s < send && *s != '\\')
1058 if ( PL_hints & HINT_NEW_STRING ) {
1059 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
1065 if (s + 1 < send && (s[1] == '\\'))
1066 s++; /* all that, just for this */
1071 SvCUR_set(sv, d - SvPVX(sv));
1073 if ( PL_hints & HINT_NEW_STRING )
1074 return new_constant(NULL, 0, "q", sv, pv, "q");
1079 * Now come three functions related to double-quote context,
1080 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1081 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1082 * interact with PL_lex_state, and create fake ( ... ) argument lists
1083 * to handle functions and concatenation.
1084 * They assume that whoever calls them will be setting up a fake
1085 * join call, because each subthing puts a ',' after it. This lets
1088 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1090 * (I'm not sure whether the spurious commas at the end of lcfirst's
1091 * arguments and join's arguments are created or not).
1096 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1098 * Pattern matching will set PL_lex_op to the pattern-matching op to
1099 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1101 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1103 * Everything else becomes a FUNC.
1105 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1106 * had an OP_CONST or OP_READLINE). This just sets us up for a
1107 * call to S_sublex_push().
1111 S_sublex_start(pTHX)
1113 register I32 op_type = yylval.ival;
1115 if (op_type == OP_NULL) {
1116 yylval.opval = PL_lex_op;
1120 if (op_type == OP_CONST || op_type == OP_READLINE) {
1121 SV *sv = tokeq(PL_lex_stuff);
1123 if (SvTYPE(sv) == SVt_PVIV) {
1124 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1130 nsv = newSVpvn(p, len);
1136 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1137 PL_lex_stuff = Nullsv;
1138 /* Allow <FH> // "foo" */
1139 if (op_type == OP_READLINE)
1140 PL_expect = XTERMORDORDOR;
1144 PL_sublex_info.super_state = PL_lex_state;
1145 PL_sublex_info.sub_inwhat = op_type;
1146 PL_sublex_info.sub_op = PL_lex_op;
1147 PL_lex_state = LEX_INTERPPUSH;
1151 yylval.opval = PL_lex_op;
1161 * Create a new scope to save the lexing state. The scope will be
1162 * ended in S_sublex_done. Returns a '(', starting the function arguments
1163 * to the uc, lc, etc. found before.
1164 * Sets PL_lex_state to LEX_INTERPCONCAT.
1172 PL_lex_state = PL_sublex_info.super_state;
1173 SAVEI32(PL_lex_dojoin);
1174 SAVEI32(PL_lex_brackets);
1175 SAVEI32(PL_lex_casemods);
1176 SAVEI32(PL_lex_starts);
1177 SAVEI32(PL_lex_state);
1178 SAVEVPTR(PL_lex_inpat);
1179 SAVEI32(PL_lex_inwhat);
1180 SAVECOPLINE(PL_curcop);
1181 SAVEPPTR(PL_bufptr);
1182 SAVEPPTR(PL_bufend);
1183 SAVEPPTR(PL_oldbufptr);
1184 SAVEPPTR(PL_oldoldbufptr);
1185 SAVEPPTR(PL_last_lop);
1186 SAVEPPTR(PL_last_uni);
1187 SAVEPPTR(PL_linestart);
1188 SAVESPTR(PL_linestr);
1189 SAVEGENERICPV(PL_lex_brackstack);
1190 SAVEGENERICPV(PL_lex_casestack);
1192 PL_linestr = PL_lex_stuff;
1193 PL_lex_stuff = Nullsv;
1195 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1196 = SvPVX(PL_linestr);
1197 PL_bufend += SvCUR(PL_linestr);
1198 PL_last_lop = PL_last_uni = Nullch;
1199 SAVEFREESV(PL_linestr);
1201 PL_lex_dojoin = FALSE;
1202 PL_lex_brackets = 0;
1203 New(899, PL_lex_brackstack, 120, char);
1204 New(899, PL_lex_casestack, 12, char);
1205 PL_lex_casemods = 0;
1206 *PL_lex_casestack = '\0';
1208 PL_lex_state = LEX_INTERPCONCAT;
1209 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1211 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1212 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1213 PL_lex_inpat = PL_sublex_info.sub_op;
1215 PL_lex_inpat = Nullop;
1222 * Restores lexer state after a S_sublex_push.
1228 if (!PL_lex_starts++) {
1229 SV *sv = newSVpvn("",0);
1230 if (SvUTF8(PL_linestr))
1232 PL_expect = XOPERATOR;
1233 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1237 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1238 PL_lex_state = LEX_INTERPCASEMOD;
1242 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1243 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1244 PL_linestr = PL_lex_repl;
1246 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1247 PL_bufend += SvCUR(PL_linestr);
1248 PL_last_lop = PL_last_uni = Nullch;
1249 SAVEFREESV(PL_linestr);
1250 PL_lex_dojoin = FALSE;
1251 PL_lex_brackets = 0;
1252 PL_lex_casemods = 0;
1253 *PL_lex_casestack = '\0';
1255 if (SvEVALED(PL_lex_repl)) {
1256 PL_lex_state = LEX_INTERPNORMAL;
1258 /* we don't clear PL_lex_repl here, so that we can check later
1259 whether this is an evalled subst; that means we rely on the
1260 logic to ensure sublex_done() is called again only via the
1261 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1264 PL_lex_state = LEX_INTERPCONCAT;
1265 PL_lex_repl = Nullsv;
1271 PL_bufend = SvPVX(PL_linestr);
1272 PL_bufend += SvCUR(PL_linestr);
1273 PL_expect = XOPERATOR;
1274 PL_sublex_info.sub_inwhat = 0;
1282 Extracts a pattern, double-quoted string, or transliteration. This
1285 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1286 processing a pattern (PL_lex_inpat is true), a transliteration
1287 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1289 Returns a pointer to the character scanned up to. Iff this is
1290 advanced from the start pointer supplied (ie if anything was
1291 successfully parsed), will leave an OP for the substring scanned
1292 in yylval. Caller must intuit reason for not parsing further
1293 by looking at the next characters herself.
1297 double-quoted style: \r and \n
1298 regexp special ones: \D \s
1300 backrefs: \1 (deprecated in substitution replacements)
1301 case and quoting: \U \Q \E
1302 stops on @ and $, but not for $ as tail anchor
1304 In transliterations:
1305 characters are VERY literal, except for - not at the start or end
1306 of the string, which indicates a range. scan_const expands the
1307 range to the full set of intermediate characters.
1309 In double-quoted strings:
1311 double-quoted style: \r and \n
1313 backrefs: \1 (deprecated)
1314 case and quoting: \U \Q \E
1317 scan_const does *not* construct ops to handle interpolated strings.
1318 It stops processing as soon as it finds an embedded $ or @ variable
1319 and leaves it to the caller to work out what's going on.
1321 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1323 $ in pattern could be $foo or could be tail anchor. Assumption:
1324 it's a tail anchor if $ is the last thing in the string, or if it's
1325 followed by one of ")| \n\t"
1327 \1 (backreferences) are turned into $1
1329 The structure of the code is
1330 while (there's a character to process) {
1331 handle transliteration ranges
1332 skip regexp comments
1333 skip # initiated comments in //x patterns
1334 check for embedded @foo
1335 check for embedded scalars
1337 leave intact backslashes from leave (below)
1338 deprecate \1 in strings and sub replacements
1339 handle string-changing backslashes \l \U \Q \E, etc.
1340 switch (what was escaped) {
1341 handle - in a transliteration (becomes a literal -)
1342 handle \132 octal characters
1343 handle 0x15 hex characters
1344 handle \cV (control V)
1345 handle printf backslashes (\f, \r, \n, etc)
1347 } (end if backslash)
1348 } (end while character to read)
1353 S_scan_const(pTHX_ char *start)
1355 register char *send = PL_bufend; /* end of the constant */
1356 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1357 register char *s = start; /* start of the constant */
1358 register char *d = SvPVX(sv); /* destination for copies */
1359 bool dorange = FALSE; /* are we in a translit range? */
1360 bool didrange = FALSE; /* did we just finish a range? */
1361 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1362 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1365 const char *leaveit = /* set of acceptably-backslashed characters */
1367 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1370 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1371 /* If we are doing a trans and we know we want UTF8 set expectation */
1372 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1373 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1377 while (s < send || dorange) {
1378 /* get transliterations out of the way (they're most literal) */
1379 if (PL_lex_inwhat == OP_TRANS) {
1380 /* expand a range A-Z to the full set of characters. AIE! */
1382 I32 i; /* current expanded character */
1383 I32 min; /* first character in range */
1384 I32 max; /* last character in range */
1387 char *c = (char*)utf8_hop((U8*)d, -1);
1391 *c = (char)UTF_TO_NATIVE(0xff);
1392 /* mark the range as done, and continue */
1398 i = d - SvPVX(sv); /* remember current offset */
1399 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1400 d = SvPVX(sv) + i; /* refresh d after realloc */
1401 d -= 2; /* eat the first char and the - */
1403 min = (U8)*d; /* first char in range */
1404 max = (U8)d[1]; /* last char in range */
1408 "Invalid range \"%c-%c\" in transliteration operator",
1409 (char)min, (char)max);
1413 if ((isLOWER(min) && isLOWER(max)) ||
1414 (isUPPER(min) && isUPPER(max))) {
1416 for (i = min; i <= max; i++)
1418 *d++ = NATIVE_TO_NEED(has_utf8,i);
1420 for (i = min; i <= max; i++)
1422 *d++ = NATIVE_TO_NEED(has_utf8,i);
1427 for (i = min; i <= max; i++)
1430 /* mark the range as done, and continue */
1436 /* range begins (ignore - as first or last char) */
1437 else if (*s == '-' && s+1 < send && s != start) {
1439 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1442 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1454 /* if we get here, we're not doing a transliteration */
1456 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1457 except for the last char, which will be done separately. */
1458 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1460 while (s+1 < send && *s != ')')
1461 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1463 else if (s[2] == '{' /* This should match regcomp.c */
1464 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1467 char *regparse = s + (s[2] == '{' ? 3 : 4);
1470 while (count && (c = *regparse)) {
1471 if (c == '\\' && regparse[1])
1479 if (*regparse != ')')
1480 regparse--; /* Leave one char for continuation. */
1481 while (s < regparse)
1482 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1486 /* likewise skip #-initiated comments in //x patterns */
1487 else if (*s == '#' && PL_lex_inpat &&
1488 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1489 while (s+1 < send && *s != '\n')
1490 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1493 /* check for embedded arrays
1494 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1496 else if (*s == '@' && s[1]
1497 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1500 /* check for embedded scalars. only stop if we're sure it's a
1503 else if (*s == '$') {
1504 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1506 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1507 break; /* in regexp, $ might be tail anchor */
1510 /* End of else if chain - OP_TRANS rejoin rest */
1513 if (*s == '\\' && s+1 < send) {
1516 /* some backslashes we leave behind */
1517 if (*leaveit && *s && strchr(leaveit, *s)) {
1518 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1519 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1523 /* deprecate \1 in strings and substitution replacements */
1524 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1525 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1527 if (ckWARN(WARN_SYNTAX))
1528 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1533 /* string-change backslash escapes */
1534 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1539 /* if we get here, it's either a quoted -, or a digit */
1542 /* quoted - in transliterations */
1544 if (PL_lex_inwhat == OP_TRANS) {
1551 if (ckWARN(WARN_MISC) &&
1554 Perl_warner(aTHX_ packWARN(WARN_MISC),
1555 "Unrecognized escape \\%c passed through",
1557 /* default action is to copy the quoted character */
1558 goto default_action;
1561 /* \132 indicates an octal constant */
1562 case '0': case '1': case '2': case '3':
1563 case '4': case '5': case '6': case '7':
1567 uv = grok_oct(s, &len, &flags, NULL);
1570 goto NUM_ESCAPE_INSERT;
1572 /* \x24 indicates a hex constant */
1576 char* e = strchr(s, '}');
1577 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1578 PERL_SCAN_DISALLOW_PREFIX;
1583 yyerror("Missing right brace on \\x{}");
1587 uv = grok_hex(s, &len, &flags, NULL);
1593 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1594 uv = grok_hex(s, &len, &flags, NULL);
1600 /* Insert oct or hex escaped character.
1601 * There will always enough room in sv since such
1602 * escapes will be longer than any UTF-8 sequence
1603 * they can end up as. */
1605 /* We need to map to chars to ASCII before doing the tests
1608 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1609 if (!has_utf8 && uv > 255) {
1610 /* Might need to recode whatever we have
1611 * accumulated so far if it contains any
1614 * (Can't we keep track of that and avoid
1615 * this rescan? --jhi)
1619 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1620 if (!NATIVE_IS_INVARIANT(*c)) {
1625 STRLEN offset = d - SvPVX(sv);
1627 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1631 while (src >= (U8 *)SvPVX(sv)) {
1632 if (!NATIVE_IS_INVARIANT(*src)) {
1633 U8 ch = NATIVE_TO_ASCII(*src);
1634 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1635 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1645 if (has_utf8 || uv > 255) {
1646 d = (char*)uvchr_to_utf8((U8*)d, uv);
1648 if (PL_lex_inwhat == OP_TRANS &&
1649 PL_sublex_info.sub_op) {
1650 PL_sublex_info.sub_op->op_private |=
1651 (PL_lex_repl ? OPpTRANS_FROM_UTF
1664 /* \N{LATIN SMALL LETTER A} is a named character */
1668 char* e = strchr(s, '}');
1674 yyerror("Missing right brace on \\N{}");
1678 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1680 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1681 PERL_SCAN_DISALLOW_PREFIX;
1684 uv = grok_hex(s, &len, &flags, NULL);
1686 goto NUM_ESCAPE_INSERT;
1688 res = newSVpvn(s + 1, e - s - 1);
1689 res = new_constant( Nullch, 0, "charnames",
1690 res, Nullsv, "\\N{...}" );
1692 sv_utf8_upgrade(res);
1693 str = SvPV(res,len);
1694 #ifdef EBCDIC_NEVER_MIND
1695 /* charnames uses pack U and that has been
1696 * recently changed to do the below uni->native
1697 * mapping, so this would be redundant (and wrong,
1698 * the code point would be doubly converted).
1699 * But leave this in just in case the pack U change
1700 * gets revoked, but the semantics is still
1701 * desireable for charnames. --jhi */
1703 UV uv = utf8_to_uvchr((U8*)str, 0);
1706 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
1708 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1709 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1710 str = SvPV(res, len);
1714 if (!has_utf8 && SvUTF8(res)) {
1715 char *ostart = SvPVX(sv);
1716 SvCUR_set(sv, d - ostart);
1719 sv_utf8_upgrade(sv);
1720 /* this just broke our allocation above... */
1721 SvGROW(sv, (STRLEN)(send - start));
1722 d = SvPVX(sv) + SvCUR(sv);
1725 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1726 char *odest = SvPVX(sv);
1728 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1729 d = SvPVX(sv) + (d - odest);
1731 Copy(str, d, len, char);
1738 yyerror("Missing braces on \\N{}");
1741 /* \c is a control character */
1750 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1753 yyerror("Missing control char name in \\c");
1757 /* printf-style backslashes, formfeeds, newlines, etc */
1759 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1762 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1765 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1768 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1771 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1774 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1777 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1783 } /* end if (backslash) */
1786 /* If we started with encoded form, or already know we want it
1787 and then encode the next character */
1788 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1790 UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1791 STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1794 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1795 STRLEN off = d - SvPVX(sv);
1796 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1798 d = (char*)uvchr_to_utf8((U8*)d, uv);
1802 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1804 } /* while loop to process each character */
1806 /* terminate the string and set up the sv */
1808 SvCUR_set(sv, d - SvPVX(sv));
1809 if (SvCUR(sv) >= SvLEN(sv))
1810 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1813 if (PL_encoding && !has_utf8) {
1814 sv_recode_to_utf8(sv, PL_encoding);
1820 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1821 PL_sublex_info.sub_op->op_private |=
1822 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1826 /* shrink the sv if we allocated more than we used */
1827 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1828 SvLEN_set(sv, SvCUR(sv) + 1);
1829 Renew(SvPVX(sv), SvLEN(sv), char);
1832 /* return the substring (via yylval) only if we parsed anything */
1833 if (s > PL_bufptr) {
1834 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1835 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1837 ( PL_lex_inwhat == OP_TRANS
1839 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1842 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1849 * Returns TRUE if there's more to the expression (e.g., a subscript),
1852 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1854 * ->[ and ->{ return TRUE
1855 * { and [ outside a pattern are always subscripts, so return TRUE
1856 * if we're outside a pattern and it's not { or [, then return FALSE
1857 * if we're in a pattern and the first char is a {
1858 * {4,5} (any digits around the comma) returns FALSE
1859 * if we're in a pattern and the first char is a [
1861 * [SOMETHING] has a funky algorithm to decide whether it's a
1862 * character class or not. It has to deal with things like
1863 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1864 * anything else returns TRUE
1867 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1870 S_intuit_more(pTHX_ register char *s)
1872 if (PL_lex_brackets)
1874 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1876 if (*s != '{' && *s != '[')
1881 /* In a pattern, so maybe we have {n,m}. */
1898 /* On the other hand, maybe we have a character class */
1901 if (*s == ']' || *s == '^')
1904 /* this is terrifying, and it works */
1905 int weight = 2; /* let's weigh the evidence */
1907 unsigned char un_char = 255, last_un_char;
1908 char *send = strchr(s,']');
1909 char tmpbuf[sizeof PL_tokenbuf * 4];
1911 if (!send) /* has to be an expression */
1914 Zero(seen,256,char);
1917 else if (isDIGIT(*s)) {
1919 if (isDIGIT(s[1]) && s[2] == ']')
1925 for (; s < send; s++) {
1926 last_un_char = un_char;
1927 un_char = (unsigned char)*s;
1932 weight -= seen[un_char] * 10;
1933 if (isALNUM_lazy_if(s+1,UTF)) {
1934 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1935 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1940 else if (*s == '$' && s[1] &&
1941 strchr("[#!%*<>()-=",s[1])) {
1942 if (/*{*/ strchr("])} =",s[2]))
1951 if (strchr("wds]",s[1]))
1953 else if (seen['\''] || seen['"'])
1955 else if (strchr("rnftbxcav",s[1]))
1957 else if (isDIGIT(s[1])) {
1959 while (s[1] && isDIGIT(s[1]))
1969 if (strchr("aA01! ",last_un_char))
1971 if (strchr("zZ79~",s[1]))
1973 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1974 weight -= 5; /* cope with negative subscript */
1977 if (!isALNUM(last_un_char)
1978 && !(last_un_char == '$' || last_un_char == '@'
1979 || last_un_char == '&')
1980 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
1985 if (keyword(tmpbuf, d - tmpbuf))
1988 if (un_char == last_un_char + 1)
1990 weight -= seen[un_char];
1995 if (weight >= 0) /* probably a character class */
2005 * Does all the checking to disambiguate
2007 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2008 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2010 * First argument is the stuff after the first token, e.g. "bar".
2012 * Not a method if bar is a filehandle.
2013 * Not a method if foo is a subroutine prototyped to take a filehandle.
2014 * Not a method if it's really "Foo $bar"
2015 * Method if it's "foo $bar"
2016 * Not a method if it's really "print foo $bar"
2017 * Method if it's really "foo package::" (interpreted as package->foo)
2018 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2019 * Not a method if bar is a filehandle or package, but is quoted with
2024 S_intuit_method(pTHX_ char *start, GV *gv)
2026 char *s = start + (*start == '$');
2027 char tmpbuf[sizeof PL_tokenbuf];
2035 if ((cv = GvCVu(gv))) {
2036 char *proto = SvPVX(cv);
2046 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2047 /* start is the beginning of the possible filehandle/object,
2048 * and s is the end of it
2049 * tmpbuf is a copy of it
2052 if (*start == '$') {
2053 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2058 return *s == '(' ? FUNCMETH : METHOD;
2060 if (!keyword(tmpbuf, len)) {
2061 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2066 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2067 if (indirgv && GvCVu(indirgv))
2069 /* filehandle or package name makes it a method */
2070 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2072 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2073 return 0; /* no assumptions -- "=>" quotes bearword */
2075 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
2076 newSVpvn(tmpbuf,len));
2077 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
2081 return *s == '(' ? FUNCMETH : METHOD;
2089 * Return a string of Perl code to load the debugger. If PERL5DB
2090 * is set, it will return the contents of that, otherwise a
2091 * compile-time require of perl5db.pl.
2098 char *pdb = PerlEnv_getenv("PERL5DB");
2102 SETERRNO(0,SS_NORMAL);
2103 return "BEGIN { require 'perl5db.pl' }";
2109 /* Encoded script support. filter_add() effectively inserts a
2110 * 'pre-processing' function into the current source input stream.
2111 * Note that the filter function only applies to the current source file
2112 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2114 * The datasv parameter (which may be NULL) can be used to pass
2115 * private data to this instance of the filter. The filter function
2116 * can recover the SV using the FILTER_DATA macro and use it to
2117 * store private buffers and state information.
2119 * The supplied datasv parameter is upgraded to a PVIO type
2120 * and the IoDIRP/IoANY field is used to store the function pointer,
2121 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2122 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2123 * private use must be set using malloc'd pointers.
2127 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2132 if (!PL_rsfp_filters)
2133 PL_rsfp_filters = newAV();
2135 datasv = NEWSV(255,0);
2136 if (!SvUPGRADE(datasv, SVt_PVIO))
2137 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
2138 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
2139 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2140 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2141 (void*)funcp, SvPV_nolen(datasv)));
2142 av_unshift(PL_rsfp_filters, 1);
2143 av_store(PL_rsfp_filters, 0, datasv) ;
2148 /* Delete most recently added instance of this filter function. */
2150 Perl_filter_del(pTHX_ filter_t funcp)
2153 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2154 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2156 /* if filter is on top of stack (usual case) just pop it off */
2157 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2158 if (IoANY(datasv) == (void *)funcp) {
2159 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2160 IoANY(datasv) = (void *)NULL;
2161 sv_free(av_pop(PL_rsfp_filters));
2165 /* we need to search for the correct entry and clear it */
2166 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2170 /* Invoke the idxth filter function for the current rsfp. */
2171 /* maxlen 0 = read one text line */
2173 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2178 if (!PL_rsfp_filters)
2180 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2181 /* Provide a default input filter to make life easy. */
2182 /* Note that we append to the line. This is handy. */
2183 DEBUG_P(PerlIO_printf(Perl_debug_log,
2184 "filter_read %d: from rsfp\n", idx));
2188 int old_len = SvCUR(buf_sv) ;
2190 /* ensure buf_sv is large enough */
2191 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2192 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2193 if (PerlIO_error(PL_rsfp))
2194 return -1; /* error */
2196 return 0 ; /* end of file */
2198 SvCUR_set(buf_sv, old_len + len) ;
2201 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2202 if (PerlIO_error(PL_rsfp))
2203 return -1; /* error */
2205 return 0 ; /* end of file */
2208 return SvCUR(buf_sv);
2210 /* Skip this filter slot if filter has been deleted */
2211 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2212 DEBUG_P(PerlIO_printf(Perl_debug_log,
2213 "filter_read %d: skipped (filter deleted)\n",
2215 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2217 /* Get function pointer hidden within datasv */
2218 funcp = (filter_t)IoANY(datasv);
2219 DEBUG_P(PerlIO_printf(Perl_debug_log,
2220 "filter_read %d: via function %p (%s)\n",
2221 idx, (void*)funcp, SvPV_nolen(datasv)));
2222 /* Call function. The function is expected to */
2223 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2224 /* Return: <0:error, =0:eof, >0:not eof */
2225 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2229 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2231 #ifdef PERL_CR_FILTER
2232 if (!PL_rsfp_filters) {
2233 filter_add(S_cr_textfilter,NULL);
2236 if (PL_rsfp_filters) {
2238 SvCUR_set(sv, 0); /* start with empty line */
2239 if (FILTER_READ(0, sv, 0) > 0)
2240 return ( SvPVX(sv) ) ;
2245 return (sv_gets(sv, fp, append));
2249 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2253 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2257 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2258 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2260 return GvHV(gv); /* Foo:: */
2263 /* use constant CLASS => 'MyClass' */
2264 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2266 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2267 pkgname = SvPV_nolen(sv);
2271 return gv_stashpv(pkgname, FALSE);
2275 static char* exp_name[] =
2276 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2277 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2284 Works out what to call the token just pulled out of the input
2285 stream. The yacc parser takes care of taking the ops we return and
2286 stitching them into a tree.
2292 if read an identifier
2293 if we're in a my declaration
2294 croak if they tried to say my($foo::bar)
2295 build the ops for a my() declaration
2296 if it's an access to a my() variable
2297 are we in a sort block?
2298 croak if my($a); $a <=> $b
2299 build ops for access to a my() variable
2300 if in a dq string, and they've said @foo and we can't find @foo
2302 build ops for a bareword
2303 if we already built the token before, use it.
2308 #pragma segment Perl_yylex
2313 register char *s = PL_bufptr;
2320 I32 orig_keyword = 0;
2323 PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
2324 lex_state_names[PL_lex_state]);
2326 /* check if there's an identifier for us to look at */
2327 if (PL_pending_ident)
2328 return REPORT(S_pending_ident(aTHX));
2330 /* no identifier pending identification */
2332 switch (PL_lex_state) {
2334 case LEX_NORMAL: /* Some compilers will produce faster */
2335 case LEX_INTERPNORMAL: /* code if we comment these out. */
2339 /* when we've already built the next token, just pull it out of the queue */
2342 yylval = PL_nextval[PL_nexttoke];
2344 PL_lex_state = PL_lex_defer;
2345 PL_expect = PL_lex_expect;
2346 PL_lex_defer = LEX_NORMAL;
2348 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2349 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2350 (IV)PL_nexttype[PL_nexttoke]); });
2352 return REPORT(PL_nexttype[PL_nexttoke]);
2354 /* interpolated case modifiers like \L \U, including \Q and \E.
2355 when we get here, PL_bufptr is at the \
2357 case LEX_INTERPCASEMOD:
2359 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2360 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2362 /* handle \E or end of string */
2363 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2367 if (PL_lex_casemods) {
2368 oldmod = PL_lex_casestack[--PL_lex_casemods];
2369 PL_lex_casestack[PL_lex_casemods] = '\0';
2371 if (PL_bufptr != PL_bufend
2372 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2374 PL_lex_state = LEX_INTERPCONCAT;
2378 if (PL_bufptr != PL_bufend)
2380 PL_lex_state = LEX_INTERPCONCAT;
2384 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2385 "### Saw case modifier at '%s'\n", PL_bufptr); });
2387 if (s[1] == '\\' && s[2] == 'E') {
2389 PL_lex_state = LEX_INTERPCONCAT;
2393 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2394 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2395 if ((*s == 'L' || *s == 'U') &&
2396 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2397 PL_lex_casestack[--PL_lex_casemods] = '\0';
2400 if (PL_lex_casemods > 10)
2401 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2402 PL_lex_casestack[PL_lex_casemods++] = *s;
2403 PL_lex_casestack[PL_lex_casemods] = '\0';
2404 PL_lex_state = LEX_INTERPCONCAT;
2405 PL_nextval[PL_nexttoke].ival = 0;
2408 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2410 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2412 PL_nextval[PL_nexttoke].ival = OP_LC;
2414 PL_nextval[PL_nexttoke].ival = OP_UC;
2416 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2418 Perl_croak(aTHX_ "panic: yylex");
2422 if (PL_lex_starts) {
2425 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2426 if (PL_lex_casemods == 1 && PL_lex_inpat)
2435 case LEX_INTERPPUSH:
2436 return REPORT(sublex_push());
2438 case LEX_INTERPSTART:
2439 if (PL_bufptr == PL_bufend)
2440 return REPORT(sublex_done());
2441 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2442 "### Interpolated variable at '%s'\n", PL_bufptr); });
2444 PL_lex_dojoin = (*PL_bufptr == '@');
2445 PL_lex_state = LEX_INTERPNORMAL;
2446 if (PL_lex_dojoin) {
2447 PL_nextval[PL_nexttoke].ival = 0;
2449 force_ident("\"", '$');
2450 PL_nextval[PL_nexttoke].ival = 0;
2452 PL_nextval[PL_nexttoke].ival = 0;
2454 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2457 if (PL_lex_starts++) {
2459 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2460 if (!PL_lex_casemods && PL_lex_inpat)
2467 case LEX_INTERPENDMAYBE:
2468 if (intuit_more(PL_bufptr)) {
2469 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2475 if (PL_lex_dojoin) {
2476 PL_lex_dojoin = FALSE;
2477 PL_lex_state = LEX_INTERPCONCAT;
2480 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2481 && SvEVALED(PL_lex_repl))
2483 if (PL_bufptr != PL_bufend)
2484 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2485 PL_lex_repl = Nullsv;
2488 case LEX_INTERPCONCAT:
2490 if (PL_lex_brackets)
2491 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2493 if (PL_bufptr == PL_bufend)
2494 return REPORT(sublex_done());
2496 if (SvIVX(PL_linestr) == '\'') {
2497 SV *sv = newSVsv(PL_linestr);
2500 else if ( PL_hints & HINT_NEW_RE )
2501 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2502 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2506 s = scan_const(PL_bufptr);
2508 PL_lex_state = LEX_INTERPCASEMOD;
2510 PL_lex_state = LEX_INTERPSTART;
2513 if (s != PL_bufptr) {
2514 PL_nextval[PL_nexttoke] = yylval;
2517 if (PL_lex_starts++) {
2518 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2519 if (!PL_lex_casemods && PL_lex_inpat)
2532 PL_lex_state = LEX_NORMAL;
2533 s = scan_formline(PL_bufptr);
2534 if (!PL_lex_formbrack)
2540 PL_oldoldbufptr = PL_oldbufptr;
2543 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
2544 exp_name[PL_expect], s);
2550 if (isIDFIRST_lazy_if(s,UTF))
2552 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2555 goto fake_eof; /* emulate EOF on ^D or ^Z */
2560 if (PL_lex_brackets) {
2561 if (PL_lex_formbrack)
2562 yyerror("Format not terminated");
2564 yyerror("Missing right curly or square bracket");
2566 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2567 "### Tokener got EOF\n");
2571 if (s++ < PL_bufend)
2572 goto retry; /* ignore stray nulls */
2575 if (!PL_in_eval && !PL_preambled) {
2576 PL_preambled = TRUE;
2577 sv_setpv(PL_linestr,incl_perldb());
2578 if (SvCUR(PL_linestr))
2579 sv_catpvn(PL_linestr,";", 1);
2581 while(AvFILLp(PL_preambleav) >= 0) {
2582 SV *tmpsv = av_shift(PL_preambleav);
2583 sv_catsv(PL_linestr, tmpsv);
2584 sv_catpvn(PL_linestr, ";", 1);
2587 sv_free((SV*)PL_preambleav);
2588 PL_preambleav = NULL;
2590 if (PL_minus_n || PL_minus_p) {
2591 sv_catpv(PL_linestr, "LINE: while (<>) {");
2593 sv_catpv(PL_linestr,"chomp;");
2596 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2597 || *PL_splitstr == '"')
2598 && strchr(PL_splitstr + 1, *PL_splitstr))
2599 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2601 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2602 bytes can be used as quoting characters. :-) */
2603 /* The count here deliberately includes the NUL
2604 that terminates the C string constant. This
2605 embeds the opening NUL into the string. */
2606 sv_catpvn(PL_linestr, "our @F=split(q", 15);
2611 sv_catpvn(PL_linestr, s, 1);
2612 sv_catpvn(PL_linestr, s, 1);
2614 /* This loop will embed the trailing NUL of
2615 PL_linestr as the last thing it does before
2617 sv_catpvn(PL_linestr, ");", 2);
2621 sv_catpv(PL_linestr,"our @F=split(' ');");
2624 sv_catpvn(PL_linestr, "\n", 1);
2625 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2626 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2627 PL_last_lop = PL_last_uni = Nullch;
2628 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2629 SV *sv = NEWSV(85,0);
2631 sv_upgrade(sv, SVt_PVMG);
2632 sv_setsv(sv,PL_linestr);
2635 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2640 bof = PL_rsfp ? TRUE : FALSE;
2641 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2644 if (PL_preprocess && !PL_in_eval)
2645 (void)PerlProc_pclose(PL_rsfp);
2646 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2647 PerlIO_clearerr(PL_rsfp);
2649 (void)PerlIO_close(PL_rsfp);
2651 PL_doextract = FALSE;
2653 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2654 sv_setpv(PL_linestr,PL_minus_p
2655 ? ";}continue{print;}" : ";}");
2656 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2657 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2658 PL_last_lop = PL_last_uni = Nullch;
2659 PL_minus_n = PL_minus_p = 0;
2662 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2663 PL_last_lop = PL_last_uni = Nullch;
2664 sv_setpv(PL_linestr,"");
2665 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2667 /* If it looks like the start of a BOM or raw UTF-16,
2668 * check if it in fact is. */
2674 #ifdef PERLIO_IS_STDIO
2675 # ifdef __GNU_LIBRARY__
2676 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2677 # define FTELL_FOR_PIPE_IS_BROKEN
2681 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2682 # define FTELL_FOR_PIPE_IS_BROKEN
2687 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2688 /* This loses the possibility to detect the bof
2689 * situation on perl -P when the libc5 is being used.
2690 * Workaround? Maybe attach some extra state to PL_rsfp?
2693 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2695 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2698 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2699 s = swallow_bom((U8*)s);
2703 /* Incest with pod. */
2704 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2705 sv_setpv(PL_linestr, "");
2706 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2707 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2708 PL_last_lop = PL_last_uni = Nullch;
2709 PL_doextract = FALSE;
2713 } while (PL_doextract);
2714 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2715 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2716 SV *sv = NEWSV(85,0);
2718 sv_upgrade(sv, SVt_PVMG);
2719 sv_setsv(sv,PL_linestr);
2722 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2724 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2725 PL_last_lop = PL_last_uni = Nullch;
2726 if (CopLINE(PL_curcop) == 1) {
2727 while (s < PL_bufend && isSPACE(*s))
2729 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2733 if (*s == '#' && *(s+1) == '!')
2735 #ifdef ALTERNATE_SHEBANG
2737 static char as[] = ALTERNATE_SHEBANG;
2738 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2739 d = s + (sizeof(as) - 1);
2741 #endif /* ALTERNATE_SHEBANG */
2750 while (*d && !isSPACE(*d))
2754 #ifdef ARG_ZERO_IS_SCRIPT
2755 if (ipathend > ipath) {
2757 * HP-UX (at least) sets argv[0] to the script name,
2758 * which makes $^X incorrect. And Digital UNIX and Linux,
2759 * at least, set argv[0] to the basename of the Perl
2760 * interpreter. So, having found "#!", we'll set it right.
2762 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2763 assert(SvPOK(x) || SvGMAGICAL(x));
2764 if (sv_eq(x, CopFILESV(PL_curcop))) {
2765 sv_setpvn(x, ipath, ipathend - ipath);
2771 char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2772 char *lstart = SvPV(x,llen);
2774 bstart += blen - llen;
2775 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2776 sv_setpvn(x, ipath, ipathend - ipath);
2781 TAINT_NOT; /* $^X is always tainted, but that's OK */
2783 #endif /* ARG_ZERO_IS_SCRIPT */
2788 d = instr(s,"perl -");
2790 d = instr(s,"perl");
2792 /* avoid getting into infinite loops when shebang
2793 * line contains "Perl" rather than "perl" */
2795 for (d = ipathend-4; d >= ipath; --d) {
2796 if ((*d == 'p' || *d == 'P')
2797 && !ibcmp(d, "perl", 4))
2807 #ifdef ALTERNATE_SHEBANG
2809 * If the ALTERNATE_SHEBANG on this system starts with a
2810 * character that can be part of a Perl expression, then if
2811 * we see it but not "perl", we're probably looking at the
2812 * start of Perl code, not a request to hand off to some
2813 * other interpreter. Similarly, if "perl" is there, but
2814 * not in the first 'word' of the line, we assume the line
2815 * contains the start of the Perl program.
2817 if (d && *s != '#') {
2819 while (*c && !strchr("; \t\r\n\f\v#", *c))
2822 d = Nullch; /* "perl" not in first word; ignore */
2824 *s = '#'; /* Don't try to parse shebang line */
2826 #endif /* ALTERNATE_SHEBANG */
2827 #ifndef MACOS_TRADITIONAL
2832 !instr(s,"indir") &&
2833 instr(PL_origargv[0],"perl"))
2839 while (s < PL_bufend && isSPACE(*s))
2841 if (s < PL_bufend) {
2842 Newz(899,newargv,PL_origargc+3,char*);
2844 while (s < PL_bufend && !isSPACE(*s))
2847 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2850 newargv = PL_origargv;
2853 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2855 Perl_croak(aTHX_ "Can't exec %s", ipath);
2859 U32 oldpdb = PL_perldb;
2860 bool oldn = PL_minus_n;
2861 bool oldp = PL_minus_p;
2863 while (*d && !isSPACE(*d)) d++;
2864 while (SPACE_OR_TAB(*d)) d++;
2867 bool switches_done = PL_doswitches;
2869 if (*d == 'M' || *d == 'm') {
2871 while (*d && !isSPACE(*d)) d++;
2872 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2875 d = moreswitches(d);
2877 if (PL_doswitches && !switches_done) {
2878 int argc = PL_origargc;
2879 char **argv = PL_origargv;
2882 } while (argc && argv[0][0] == '-' && argv[0][1]);
2883 init_argv_symbols(argc,argv);
2885 if ((PERLDB_LINE && !oldpdb) ||
2886 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2887 /* if we have already added "LINE: while (<>) {",
2888 we must not do it again */
2890 sv_setpv(PL_linestr, "");
2891 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2892 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2893 PL_last_lop = PL_last_uni = Nullch;
2894 PL_preambled = FALSE;
2896 (void)gv_fetchfile(PL_origfilename);
2899 if (PL_doswitches && !switches_done) {
2900 int argc = PL_origargc;
2901 char **argv = PL_origargv;
2904 } while (argc && argv[0][0] == '-' && argv[0][1]);
2905 init_argv_symbols(argc,argv);
2911 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2913 PL_lex_state = LEX_FORMLINE;
2918 #ifdef PERL_STRICT_CR
2919 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2921 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2923 case ' ': case '\t': case '\f': case 013:
2924 #ifdef MACOS_TRADITIONAL
2931 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2932 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2933 /* handle eval qq[#line 1 "foo"\n ...] */
2934 CopLINE_dec(PL_curcop);
2938 while (s < d && *s != '\n')
2942 else if (s > d) /* Found by Ilya: feed random input to Perl. */
2943 Perl_croak(aTHX_ "panic: input overflow");
2945 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2947 PL_lex_state = LEX_FORMLINE;
2957 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2964 while (s < PL_bufend && SPACE_OR_TAB(*s))
2967 if (strnEQ(s,"=>",2)) {
2968 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2969 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2970 "### Saw unary minus before =>, forcing word '%s'\n", s);
2972 OPERATOR('-'); /* unary minus */
2974 PL_last_uni = PL_oldbufptr;
2976 case 'r': ftst = OP_FTEREAD; break;
2977 case 'w': ftst = OP_FTEWRITE; break;
2978 case 'x': ftst = OP_FTEEXEC; break;
2979 case 'o': ftst = OP_FTEOWNED; break;
2980 case 'R': ftst = OP_FTRREAD; break;
2981 case 'W': ftst = OP_FTRWRITE; break;
2982 case 'X': ftst = OP_FTREXEC; break;
2983 case 'O': ftst = OP_FTROWNED; break;
2984 case 'e': ftst = OP_FTIS; break;
2985 case 'z': ftst = OP_FTZERO; break;
2986 case 's': ftst = OP_FTSIZE; break;
2987 case 'f': ftst = OP_FTFILE; break;
2988 case 'd': ftst = OP_FTDIR; break;
2989 case 'l': ftst = OP_FTLINK; break;
2990 case 'p': ftst = OP_FTPIPE; break;
2991 case 'S': ftst = OP_FTSOCK; break;
2992 case 'u': ftst = OP_FTSUID; break;
2993 case 'g': ftst = OP_FTSGID; break;
2994 case 'k': ftst = OP_FTSVTX; break;
2995 case 'b': ftst = OP_FTBLK; break;
2996 case 'c': ftst = OP_FTCHR; break;
2997 case 't': ftst = OP_FTTTY; break;
2998 case 'T': ftst = OP_FTTEXT; break;
2999 case 'B': ftst = OP_FTBINARY; break;
3000 case 'M': case 'A': case 'C':
3001 gv_fetchpv("\024",TRUE, SVt_PV);
3003 case 'M': ftst = OP_FTMTIME; break;
3004 case 'A': ftst = OP_FTATIME; break;
3005 case 'C': ftst = OP_FTCTIME; break;
3013 PL_last_lop_op = (OPCODE)ftst;
3014 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3015 "### Saw file test %c\n", (int)ftst);
3020 /* Assume it was a minus followed by a one-letter named
3021 * subroutine call (or a -bareword), then. */
3022 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3023 "### '-%c' looked like a file test but was not\n",
3032 if (PL_expect == XOPERATOR)
3037 else if (*s == '>') {
3040 if (isIDFIRST_lazy_if(s,UTF)) {
3041 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3049 if (PL_expect == XOPERATOR)
3052 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3054 OPERATOR('-'); /* unary minus */
3061 if (PL_expect == XOPERATOR)
3066 if (PL_expect == XOPERATOR)
3069 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3075 if (PL_expect != XOPERATOR) {
3076 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3077 PL_expect = XOPERATOR;
3078 force_ident(PL_tokenbuf, '*');
3091 if (PL_expect == XOPERATOR) {
3095 PL_tokenbuf[0] = '%';
3096 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3097 if (!PL_tokenbuf[1]) {
3100 PL_pending_ident = '%';
3119 switch (PL_expect) {
3122 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3124 PL_bufptr = s; /* update in case we back off */
3130 PL_expect = XTERMBLOCK;
3134 while (isIDFIRST_lazy_if(s,UTF)) {
3135 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3136 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3137 if (tmp < 0) tmp = -tmp;
3153 d = scan_str(d,TRUE,TRUE);
3155 /* MUST advance bufptr here to avoid bogus
3156 "at end of line" context messages from yyerror().
3158 PL_bufptr = s + len;
3159 yyerror("Unterminated attribute parameter in attribute list");
3162 return REPORT(0); /* EOF indicator */
3166 SV *sv = newSVpvn(s, len);
3167 sv_catsv(sv, PL_lex_stuff);
3168 attrs = append_elem(OP_LIST, attrs,
3169 newSVOP(OP_CONST, 0, sv));
3170 SvREFCNT_dec(PL_lex_stuff);
3171 PL_lex_stuff = Nullsv;
3174 if (len == 6 && strnEQ(s, "unique", len)) {
3175 if (PL_in_my == KEY_our)
3177 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3179 ; /* skip to avoid loading attributes.pm */
3182 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3185 /* NOTE: any CV attrs applied here need to be part of
3186 the CVf_BUILTIN_ATTRS define in cv.h! */
3187 else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3188 CvLVALUE_on(PL_compcv);
3189 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3190 CvLOCKED_on(PL_compcv);
3191 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3192 CvMETHOD_on(PL_compcv);
3193 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3194 CvASSERTION_on(PL_compcv);
3195 /* After we've set the flags, it could be argued that
3196 we don't need to do the attributes.pm-based setting
3197 process, and shouldn't bother appending recognized
3198 flags. To experiment with that, uncomment the
3199 following "else". (Note that's already been
3200 uncommented. That keeps the above-applied built-in
3201 attributes from being intercepted (and possibly
3202 rejected) by a package's attribute routines, but is
3203 justified by the performance win for the common case
3204 of applying only built-in attributes.) */
3206 attrs = append_elem(OP_LIST, attrs,
3207 newSVOP(OP_CONST, 0,
3211 if (*s == ':' && s[1] != ':')
3214 break; /* require real whitespace or :'s */
3216 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3217 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3218 char q = ((*s == '\'') ? '"' : '\'');
3219 /* If here for an expression, and parsed no attrs, back off. */
3220 if (tmp == '=' && !attrs) {
3224 /* MUST advance bufptr here to avoid bogus "at end of line"
3225 context messages from yyerror().
3229 yyerror("Unterminated attribute list");
3231 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3239 PL_nextval[PL_nexttoke].opval = attrs;
3247 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3248 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3265 if (PL_lex_brackets <= 0)
3266 yyerror("Unmatched right square bracket");
3269 if (PL_lex_state == LEX_INTERPNORMAL) {
3270 if (PL_lex_brackets == 0) {
3271 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3272 PL_lex_state = LEX_INTERPEND;
3279 if (PL_lex_brackets > 100) {
3280 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3282 switch (PL_expect) {
3284 if (PL_lex_formbrack) {
3288 if (PL_oldoldbufptr == PL_last_lop)
3289 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3291 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3292 OPERATOR(HASHBRACK);
3294 while (s < PL_bufend && SPACE_OR_TAB(*s))
3297 PL_tokenbuf[0] = '\0';
3298 if (d < PL_bufend && *d == '-') {
3299 PL_tokenbuf[0] = '-';
3301 while (d < PL_bufend && SPACE_OR_TAB(*d))
3304 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3305 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3307 while (d < PL_bufend && SPACE_OR_TAB(*d))
3310 char minus = (PL_tokenbuf[0] == '-');
3311 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3319 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3324 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3329 if (PL_oldoldbufptr == PL_last_lop)
3330 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3332 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3335 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3337 /* This hack is to get the ${} in the message. */
3339 yyerror("syntax error");
3342 OPERATOR(HASHBRACK);
3344 /* This hack serves to disambiguate a pair of curlies
3345 * as being a block or an anon hash. Normally, expectation
3346 * determines that, but in cases where we're not in a
3347 * position to expect anything in particular (like inside
3348 * eval"") we have to resolve the ambiguity. This code
3349 * covers the case where the first term in the curlies is a
3350 * quoted string. Most other cases need to be explicitly
3351 * disambiguated by prepending a `+' before the opening
3352 * curly in order to force resolution as an anon hash.
3354 * XXX should probably propagate the outer expectation
3355 * into eval"" to rely less on this hack, but that could
3356 * potentially break current behavior of eval"".
3360 if (*s == '\'' || *s == '"' || *s == '`') {
3361 /* common case: get past first string, handling escapes */
3362 for (t++; t < PL_bufend && *t != *s;)
3363 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3367 else if (*s == 'q') {
3370 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3373 /* skip q//-like construct */
3375 char open, close, term;
3378 while (t < PL_bufend && isSPACE(*t))
3380 /* check for q => */
3381 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3382 OPERATOR(HASHBRACK);
3386 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3390 for (t++; t < PL_bufend; t++) {
3391 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3393 else if (*t == open)
3397 for (t++; t < PL_bufend; t++) {
3398 if (*t == '\\' && t+1 < PL_bufend)
3400 else if (*t == close && --brackets <= 0)
3402 else if (*t == open)
3409 /* skip plain q word */
3410 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3413 else if (isALNUM_lazy_if(t,UTF)) {
3415 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3418 while (t < PL_bufend && isSPACE(*t))
3420 /* if comma follows first term, call it an anon hash */
3421 /* XXX it could be a comma expression with loop modifiers */
3422 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3423 || (*t == '=' && t[1] == '>')))
3424 OPERATOR(HASHBRACK);
3425 if (PL_expect == XREF)
3428 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3434 yylval.ival = CopLINE(PL_curcop);
3435 if (isSPACE(*s) || *s == '#')
3436 PL_copline = NOLINE; /* invalidate current command line number */
3441 if (PL_lex_brackets <= 0)
3442 yyerror("Unmatched right curly bracket");
3444 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3445 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3446 PL_lex_formbrack = 0;
3447 if (PL_lex_state == LEX_INTERPNORMAL) {
3448 if (PL_lex_brackets == 0) {
3449 if (PL_expect & XFAKEBRACK) {
3450 PL_expect &= XENUMMASK;
3451 PL_lex_state = LEX_INTERPEND;
3453 return yylex(); /* ignore fake brackets */
3455 if (*s == '-' && s[1] == '>')
3456 PL_lex_state = LEX_INTERPENDMAYBE;
3457 else if (*s != '[' && *s != '{')
3458 PL_lex_state = LEX_INTERPEND;
3461 if (PL_expect & XFAKEBRACK) {
3462 PL_expect &= XENUMMASK;
3464 return yylex(); /* ignore fake brackets */
3474 if (PL_expect == XOPERATOR) {
3475 if (ckWARN(WARN_SEMICOLON)
3476 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3478 CopLINE_dec(PL_curcop);
3479 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3480 CopLINE_inc(PL_curcop);
3485 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3487 PL_expect = XOPERATOR;
3488 force_ident(PL_tokenbuf, '&');
3492 yylval.ival = (OPpENTERSUB_AMPER<<8);
3511 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3512 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3514 if (PL_expect == XSTATE && isALPHA(tmp) &&
3515 (s == PL_linestart+1 || s[-2] == '\n') )
3517 if (PL_in_eval && !PL_rsfp) {
3522 if (strnEQ(s,"=cut",4)) {
3536 PL_doextract = TRUE;
3539 if (PL_lex_brackets < PL_lex_formbrack) {
3541 #ifdef PERL_STRICT_CR
3542 for (t = s; SPACE_OR_TAB(*t); t++) ;
3544 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3546 if (*t == '\n' || *t == '#') {
3558 /* was this !=~ where !~ was meant?
3559 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3561 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3564 while (t < PL_bufend && isSPACE(*t))
3567 if (*t == '/' || *t == '?' ||
3568 ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3569 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3570 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3571 "!=~ should be !~");
3580 if (PL_expect != XOPERATOR) {
3581 if (s[1] != '<' && !strchr(s,'>'))
3584 s = scan_heredoc(s);
3586 s = scan_inputsymbol(s);
3587 TERM(sublex_start());
3592 SHop(OP_LEFT_SHIFT);
3606 SHop(OP_RIGHT_SHIFT);
3615 if (PL_expect == XOPERATOR) {
3616 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3619 return REPORT(','); /* grandfather non-comma-format format */
3623 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3624 PL_tokenbuf[0] = '@';
3625 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3626 sizeof PL_tokenbuf - 1, FALSE);
3627 if (PL_expect == XOPERATOR)
3628 no_op("Array length", s);
3629 if (!PL_tokenbuf[1])
3631 PL_expect = XOPERATOR;
3632 PL_pending_ident = '#';
3636 PL_tokenbuf[0] = '$';
3637 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3638 sizeof PL_tokenbuf - 1, FALSE);
3639 if (PL_expect == XOPERATOR)
3641 if (!PL_tokenbuf[1]) {
3643 yyerror("Final $ should be \\$ or $name");
3647 /* This kludge not intended to be bulletproof. */
3648 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3649 yylval.opval = newSVOP(OP_CONST, 0,
3650 newSViv(PL_compiling.cop_arybase));
3651 yylval.opval->op_private = OPpCONST_ARYBASE;
3657 if (PL_lex_state == LEX_NORMAL)
3660 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3663 PL_tokenbuf[0] = '@';
3664 if (ckWARN(WARN_SYNTAX)) {
3666 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3669 PL_bufptr = skipspace(PL_bufptr);
3670 while (t < PL_bufend && *t != ']')
3672 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3673 "Multidimensional syntax %.*s not supported",
3674 (t - PL_bufptr) + 1, PL_bufptr);
3678 else if (*s == '{') {
3679 PL_tokenbuf[0] = '%';
3680 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3681 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3683 char tmpbuf[sizeof PL_tokenbuf];
3685 for (t++; isSPACE(*t); t++) ;
3686 if (isIDFIRST_lazy_if(t,UTF)) {
3687 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3688 for (; isSPACE(*t); t++) ;
3689 if (*t == ';' && get_cv(tmpbuf, FALSE))
3690 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3691 "You need to quote \"%s\"", tmpbuf);
3697 PL_expect = XOPERATOR;
3698 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3699 bool islop = (PL_last_lop == PL_oldoldbufptr);
3700 if (!islop || PL_last_lop_op == OP_GREPSTART)
3701 PL_expect = XOPERATOR;
3702 else if (strchr("$@\"'`q", *s))
3703 PL_expect = XTERM; /* e.g. print $fh "foo" */
3704 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3705 PL_expect = XTERM; /* e.g. print $fh &sub */
3706 else if (isIDFIRST_lazy_if(s,UTF)) {
3707 char tmpbuf[sizeof PL_tokenbuf];
3708 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3709 if ((tmp = keyword(tmpbuf, len))) {
3710 /* binary operators exclude handle interpretations */
3722 PL_expect = XTERM; /* e.g. print $fh length() */
3727 PL_expect = XTERM; /* e.g. print $fh subr() */
3730 else if (isDIGIT(*s))
3731 PL_expect = XTERM; /* e.g. print $fh 3 */
3732 else if (*s == '.' && isDIGIT(s[1]))
3733 PL_expect = XTERM; /* e.g. print $fh .3 */
3734 else if ((*s == '?' || *s == '-' || *s == '+')
3735 && !isSPACE(s[1]) && s[1] != '=')
3736 PL_expect = XTERM; /* e.g. print $fh -1 */
3737 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3738 PL_expect = XTERM; /* e.g. print $fh /.../
3739 XXX except DORDOR operator */
3740 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3741 PL_expect = XTERM; /* print $fh <<"EOF" */
3743 PL_pending_ident = '$';
3747 if (PL_expect == XOPERATOR)
3749 PL_tokenbuf[0] = '@';
3750 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3751 if (!PL_tokenbuf[1]) {
3754 if (PL_lex_state == LEX_NORMAL)
3756 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3758 PL_tokenbuf[0] = '%';
3760 /* Warn about @ where they meant $. */
3761 if (ckWARN(WARN_SYNTAX)) {
3762 if (*s == '[' || *s == '{') {
3764 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3766 if (*t == '}' || *t == ']') {
3768 PL_bufptr = skipspace(PL_bufptr);
3769 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3770 "Scalar value %.*s better written as $%.*s",
3771 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3776 PL_pending_ident = '@';
3779 case '/': /* may be division, defined-or, or pattern */
3780 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3784 case '?': /* may either be conditional or pattern */
3785 if(PL_expect == XOPERATOR) {
3793 /* A // operator. */
3803 /* Disable warning on "study /blah/" */
3804 if (PL_oldoldbufptr == PL_last_uni
3805 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3806 || memNE(PL_last_uni, "study", 5)
3807 || isALNUM_lazy_if(PL_last_uni+5,UTF)
3810 s = scan_pat(s,OP_MATCH);
3811 TERM(sublex_start());
3815 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3816 #ifdef PERL_STRICT_CR
3819 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3821 && (s == PL_linestart || s[-1] == '\n') )
3823 PL_lex_formbrack = 0;
3827 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3833 yylval.ival = OPf_SPECIAL;
3839 if (PL_expect != XOPERATOR)
3844 case '0': case '1': case '2': case '3': case '4':
3845 case '5': case '6': case '7': case '8': case '9':
3846 s = scan_num(s, &yylval);
3847 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3848 "### Saw number in '%s'\n", s);
3850 if (PL_expect == XOPERATOR)
3855 s = scan_str(s,FALSE,FALSE);
3856 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3857 "### Saw string before '%s'\n", s);
3859 if (PL_expect == XOPERATOR) {
3860 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3863 return REPORT(','); /* grandfather non-comma-format format */
3869 missingterm((char*)0);
3870 yylval.ival = OP_CONST;
3871 TERM(sublex_start());
3874 s = scan_str(s,FALSE,FALSE);
3875 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3876 "### Saw string before '%s'\n", s);
3878 if (PL_expect == XOPERATOR) {
3879 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3882 return REPORT(','); /* grandfather non-comma-format format */
3888 missingterm((char*)0);
3889 yylval.ival = OP_CONST;
3890 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3891 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3892 yylval.ival = OP_STRINGIFY;
3896 TERM(sublex_start());
3899 s = scan_str(s,FALSE,FALSE);
3900 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3901 "### Saw backtick string before '%s'\n", s);
3903 if (PL_expect == XOPERATOR)
3904 no_op("Backticks",s);
3906 missingterm((char*)0);
3907 yylval.ival = OP_BACKTICK;
3909 TERM(sublex_start());
3913 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3914 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3916 if (PL_expect == XOPERATOR)
3917 no_op("Backslash",s);
3921 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3925 while (isDIGIT(*start) || *start == '_')
3927 if (*start == '.' && isDIGIT(start[1])) {
3928 s = scan_num(s, &yylval);
3931 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3932 else if (!isALPHA(*start) && (PL_expect == XTERM
3933 || PL_expect == XREF || PL_expect == XSTATE
3934 || PL_expect == XTERMORDORDOR)) {
3938 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3941 s = scan_num(s, &yylval);
3948 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3988 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3990 /* Some keywords can be followed by any delimiter, including ':' */
3991 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3992 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3993 (PL_tokenbuf[0] == 'q' &&
3994 strchr("qwxr", PL_tokenbuf[1])))));
3996 /* x::* is just a word, unless x is "CORE" */
3997 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4001 while (d < PL_bufend && isSPACE(*d))
4002 d++; /* no comments skipped here, or s### is misparsed */
4004 /* Is this a label? */
4005 if (!tmp && PL_expect == XSTATE
4006 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4008 yylval.pval = savepv(PL_tokenbuf);
4013 /* Check for keywords */
4014 tmp = keyword(PL_tokenbuf, len);
4016 /* Is this a word before a => operator? */
4017 if (*d == '=' && d[1] == '>') {
4020 = (OP*)newSVOP(OP_CONST, 0,
4021 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4022 yylval.opval->op_private = OPpCONST_BARE;
4026 if (tmp < 0) { /* second-class keyword? */
4027 GV *ogv = Nullgv; /* override (winner) */
4028 GV *hgv = Nullgv; /* hidden (loser) */
4029 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4031 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4034 if (GvIMPORTED_CV(gv))
4036 else if (! CvMETHOD(cv))
4040 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4041 (gv = *gvp) != (GV*)&PL_sv_undef &&
4042 GvCVu(gv) && GvIMPORTED_CV(gv))
4049 tmp = 0; /* overridden by import or by GLOBAL */
4052 && -tmp==KEY_lock /* XXX generalizable kludge */
4054 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4056 tmp = 0; /* any sub overrides "weak" keyword */
4061 && PL_expect != XOPERATOR
4062 && PL_expect != XTERMORDORDOR)
4064 /* any sub overrides the "err" keyword, except when really an
4065 * operator is expected */
4068 else { /* no override */
4070 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4071 Perl_warner(aTHX_ packWARN(WARN_MISC),
4072 "dump() better written as CORE::dump()");
4076 if (ckWARN(WARN_AMBIGUOUS) && hgv
4077 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
4078 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4079 "Ambiguous call resolved as CORE::%s(), %s",
4080 GvENAME(hgv), "qualify as such or use &");
4087 default: /* not a keyword */
4091 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4093 /* Get the rest if it looks like a package qualifier */
4095 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4097 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4100 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4101 *s == '\'' ? "'" : "::");
4106 if (PL_expect == XOPERATOR) {
4107 if (PL_bufptr == PL_linestart) {
4108 CopLINE_dec(PL_curcop);
4109 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4110 CopLINE_inc(PL_curcop);
4113 no_op("Bareword",s);
4116 /* Look for a subroutine with this name in current package,
4117 unless name is "Foo::", in which case Foo is a bearword
4118 (and a package name). */
4121 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4123 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4124 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4125 "Bareword \"%s\" refers to nonexistent package",
4128 PL_tokenbuf[len] = '\0';
4135 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4138 /* if we saw a global override before, get the right name */
4141 sv = newSVpvn("CORE::GLOBAL::",14);
4142 sv_catpv(sv,PL_tokenbuf);
4145 /* If len is 0, newSVpv does strlen(), which is correct.
4146 If len is non-zero, then it will be the true length,
4147 and so the scalar will be created correctly. */
4148 sv = newSVpv(PL_tokenbuf,len);
4151 /* Presume this is going to be a bareword of some sort. */
4154 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4155 yylval.opval->op_private = OPpCONST_BARE;
4156 /* UTF-8 package name? */
4157 if (UTF && !IN_BYTES &&
4158 is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
4161 /* And if "Foo::", then that's what it certainly is. */
4166 /* See if it's the indirect object for a list operator. */
4168 if (PL_oldoldbufptr &&
4169 PL_oldoldbufptr < PL_bufptr &&
4170 (PL_oldoldbufptr == PL_last_lop
4171 || PL_oldoldbufptr == PL_last_uni) &&
4172 /* NO SKIPSPACE BEFORE HERE! */
4173 (PL_expect == XREF ||
4174 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4176 bool immediate_paren = *s == '(';
4178 /* (Now we can afford to cross potential line boundary.) */
4181 /* Two barewords in a row may indicate method call. */
4183 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4186 /* If not a declared subroutine, it's an indirect object. */
4187 /* (But it's an indir obj regardless for sort.) */
4189 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4190 ((!gv || !GvCVu(gv)) &&
4191 (PL_last_lop_op != OP_MAPSTART &&
4192 PL_last_lop_op != OP_GREPSTART))))
4194 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4199 PL_expect = XOPERATOR;
4202 /* Is this a word before a => operator? */
4203 if (*s == '=' && s[1] == '>' && !pkgname) {
4205 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4206 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4207 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4211 /* If followed by a paren, it's certainly a subroutine. */
4214 if (gv && GvCVu(gv)) {
4215 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4216 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4221 PL_nextval[PL_nexttoke].opval = yylval.opval;
4222 PL_expect = XOPERATOR;
4228 /* If followed by var or block, call it a method (unless sub) */
4230 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4231 PL_last_lop = PL_oldbufptr;
4232 PL_last_lop_op = OP_METHOD;
4236 /* If followed by a bareword, see if it looks like indir obj. */
4239 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4240 && (tmp = intuit_method(s,gv)))
4243 /* Not a method, so call it a subroutine (if defined) */
4245 if (gv && GvCVu(gv)) {
4247 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4248 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4249 "Ambiguous use of -%s resolved as -&%s()",
4250 PL_tokenbuf, PL_tokenbuf);
4251 /* Check for a constant sub */
4253 if ((sv = cv_const_sv(cv))) {
4255 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4256 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4257 yylval.opval->op_private = 0;
4261 /* Resolve to GV now. */
4262 op_free(yylval.opval);
4263 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4264 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4265 PL_last_lop = PL_oldbufptr;
4266 PL_last_lop_op = OP_ENTERSUB;
4267 /* Is there a prototype? */
4270 char *proto = SvPV((SV*)cv, len);
4273 if (*proto == '$' && proto[1] == '\0')
4275 while (*proto == ';')
4277 if (*proto == '&' && *s == '{') {
4278 sv_setpv(PL_subname, PL_curstash ?
4279 "__ANON__" : "__ANON__::__ANON__");
4283 PL_nextval[PL_nexttoke].opval = yylval.opval;
4289 /* Call it a bare word */
4291 if (PL_hints & HINT_STRICT_SUBS)
4292 yylval.opval->op_private |= OPpCONST_STRICT;
4295 if (ckWARN(WARN_RESERVED)) {
4296 if (lastchar != '-') {
4297 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4298 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4299 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4306 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4307 && ckWARN_d(WARN_AMBIGUOUS)) {
4308 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4309 "Operator or semicolon missing before %c%s",
4310 lastchar, PL_tokenbuf);
4311 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4312 "Ambiguous use of %c resolved as operator %c",
4313 lastchar, lastchar);
4319 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4320 newSVpv(CopFILE(PL_curcop),0));
4324 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4325 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4328 case KEY___PACKAGE__:
4329 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4331 ? newSVpv(HvNAME(PL_curstash), 0)
4340 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4341 char *pname = "main";
4342 if (PL_tokenbuf[2] == 'D')
4343 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4344 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4347 GvIOp(gv) = newIO();
4348 IoIFP(GvIOp(gv)) = PL_rsfp;
4349 #if defined(HAS_FCNTL) && defined(F_SETFD)
4351 int fd = PerlIO_fileno(PL_rsfp);
4352 fcntl(fd,F_SETFD,fd >= 3);
4355 /* Mark this internal pseudo-handle as clean */
4356 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4358 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4359 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4360 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4362 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4363 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4364 /* if the script was opened in binmode, we need to revert
4365 * it to text mode for compatibility; but only iff it has CRs
4366 * XXX this is a questionable hack at best. */
4367 if (PL_bufend-PL_bufptr > 2
4368 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4371 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4372 loc = PerlIO_tell(PL_rsfp);
4373 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4376 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4378 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4379 #endif /* NETWARE */
4380 #ifdef PERLIO_IS_STDIO /* really? */
4381 # if defined(__BORLANDC__)
4382 /* XXX see note in do_binmode() */
4383 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4387 PerlIO_seek(PL_rsfp, loc, 0);
4391 #ifdef PERLIO_LAYERS
4394 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4395 else if (PL_encoding) {
4402 XPUSHs(PL_encoding);
4404 call_method("name", G_SCALAR);
4408 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4409 Perl_form(aTHX_ ":encoding(%"SVf")",
4427 if (PL_expect == XSTATE) {
4434 if (*s == ':' && s[1] == ':') {
4437 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4438 if (!(tmp = keyword(PL_tokenbuf, len)))
4439 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4453 LOP(OP_ACCEPT,XTERM);
4459 LOP(OP_ATAN2,XTERM);
4465 LOP(OP_BINMODE,XTERM);
4468 LOP(OP_BLESS,XTERM);
4477 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4494 if (!PL_cryptseen) {
4495 PL_cryptseen = TRUE;
4499 LOP(OP_CRYPT,XTERM);
4502 LOP(OP_CHMOD,XTERM);
4505 LOP(OP_CHOWN,XTERM);
4508 LOP(OP_CONNECT,XTERM);
4524 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4528 PL_hints |= HINT_BLOCK_SCOPE;
4538 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4539 LOP(OP_DBMOPEN,XTERM);
4545 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4552 yylval.ival = CopLINE(PL_curcop);
4566 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4567 UNIBRACK(OP_ENTEREVAL);
4585 case KEY_endhostent:
4591 case KEY_endservent:
4594 case KEY_endprotoent:
4605 yylval.ival = CopLINE(PL_curcop);
4607 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4609 if ((PL_bufend - p) >= 3 &&
4610 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4612 else if ((PL_bufend - p) >= 4 &&
4613 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4616 if (isIDFIRST_lazy_if(p,UTF)) {
4617 p = scan_ident(p, PL_bufend,
4618 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4622 Perl_croak(aTHX_ "Missing $ on loop variable");
4627 LOP(OP_FORMLINE,XTERM);
4633 LOP(OP_FCNTL,XTERM);
4639 LOP(OP_FLOCK,XTERM);
4648 LOP(OP_GREPSTART, XREF);
4651 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4666 case KEY_getpriority:
4667 LOP(OP_GETPRIORITY,XTERM);
4669 case KEY_getprotobyname:
4672 case KEY_getprotobynumber:
4673 LOP(OP_GPBYNUMBER,XTERM);
4675 case KEY_getprotoent:
4687 case KEY_getpeername:
4688 UNI(OP_GETPEERNAME);
4690 case KEY_gethostbyname:
4693 case KEY_gethostbyaddr:
4694 LOP(OP_GHBYADDR,XTERM);
4696 case KEY_gethostent:
4699 case KEY_getnetbyname:
4702 case KEY_getnetbyaddr:
4703 LOP(OP_GNBYADDR,XTERM);
4708 case KEY_getservbyname:
4709 LOP(OP_GSBYNAME,XTERM);
4711 case KEY_getservbyport:
4712 LOP(OP_GSBYPORT,XTERM);
4714 case KEY_getservent:
4717 case KEY_getsockname:
4718 UNI(OP_GETSOCKNAME);
4720 case KEY_getsockopt:
4721 LOP(OP_GSOCKOPT,XTERM);
4743 yylval.ival = CopLINE(PL_curcop);
4747 LOP(OP_INDEX,XTERM);
4753 LOP(OP_IOCTL,XTERM);
4765 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4797 LOP(OP_LISTEN,XTERM);
4806 s = scan_pat(s,OP_MATCH);
4807 TERM(sublex_start());
4810 LOP(OP_MAPSTART, XREF);
4813 LOP(OP_MKDIR,XTERM);
4816 LOP(OP_MSGCTL,XTERM);
4819 LOP(OP_MSGGET,XTERM);
4822 LOP(OP_MSGRCV,XTERM);
4825 LOP(OP_MSGSND,XTERM);
4831 if (isIDFIRST_lazy_if(s,UTF)) {
4832 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4833 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4835 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4836 if (!PL_in_my_stash) {
4839 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4847 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4854 if (PL_expect != XSTATE)
4855 yyerror("\"no\" not allowed in expression");
4856 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4857 s = force_version(s, FALSE);
4862 if (*s == '(' || (s = skipspace(s), *s == '('))
4869 if (isIDFIRST_lazy_if(s,UTF)) {
4871 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4872 for (t=d; *t && isSPACE(*t); t++) ;
4873 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4875 && !(t[0] == '=' && t[1] == '>')
4877 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4878 "Precedence problem: open %.*s should be open(%.*s)",
4879 d - s, s, d - s, s);
4885 yylval.ival = OP_OR;
4895 LOP(OP_OPEN_DIR,XTERM);
4898 checkcomma(s,PL_tokenbuf,"filehandle");
4902 checkcomma(s,PL_tokenbuf,"filehandle");
4921 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4925 LOP(OP_PIPE_OP,XTERM);
4928 s = scan_str(s,FALSE,FALSE);
4930 missingterm((char*)0);
4931 yylval.ival = OP_CONST;
4932 TERM(sublex_start());
4938 s = scan_str(s,FALSE,FALSE);
4940 missingterm((char*)0);
4942 if (SvCUR(PL_lex_stuff)) {
4945 d = SvPV_force(PL_lex_stuff, len);
4948 for (; isSPACE(*d) && len; --len, ++d) ;
4951 if (!warned && ckWARN(WARN_QW)) {
4952 for (; !isSPACE(*d) && len; --len, ++d) {
4954 Perl_warner(aTHX_ packWARN(WARN_QW),
4955 "Possible attempt to separate words with commas");
4958 else if (*d == '#') {
4959 Perl_warner(aTHX_ packWARN(WARN_QW),
4960 "Possible attempt to put comments in qw() list");
4966 for (; !isSPACE(*d) && len; --len, ++d) ;
4968 sv = newSVpvn(b, d-b);
4969 if (DO_UTF8(PL_lex_stuff))
4971 words = append_elem(OP_LIST, words,
4972 newSVOP(OP_CONST, 0, tokeq(sv)));
4976 PL_nextval[PL_nexttoke].opval = words;
4981 SvREFCNT_dec(PL_lex_stuff);
4982 PL_lex_stuff = Nullsv;
4988 s = scan_str(s,FALSE,FALSE);
4990 missingterm((char*)0);
4991 yylval.ival = OP_STRINGIFY;
4992 if (SvIVX(PL_lex_stuff) == '\'')
4993 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4994 TERM(sublex_start());
4997 s = scan_pat(s,OP_QR);
4998 TERM(sublex_start());
5001 s = scan_str(s,FALSE,FALSE);
5003 missingterm((char*)0);
5004 yylval.ival = OP_BACKTICK;
5006 TERM(sublex_start());
5014 s = force_version(s, FALSE);
5016 else if (*s != 'v' || !isDIGIT(s[1])
5017 || (s = force_version(s, TRUE), *s == 'v'))
5019 *PL_tokenbuf = '\0';
5020 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5021 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5022 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5024 yyerror("<> should be quotes");
5032 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5036 LOP(OP_RENAME,XTERM);
5045 LOP(OP_RINDEX,XTERM);
5055 UNIDOR(OP_READLINE);
5068 LOP(OP_REVERSE,XTERM);
5071 UNIDOR(OP_READLINK);
5079 TERM(sublex_start());
5081 TOKEN(1); /* force error */
5090 LOP(OP_SELECT,XTERM);
5096 LOP(OP_SEMCTL,XTERM);
5099 LOP(OP_SEMGET,XTERM);
5102 LOP(OP_SEMOP,XTERM);
5108 LOP(OP_SETPGRP,XTERM);
5110 case KEY_setpriority:
5111 LOP(OP_SETPRIORITY,XTERM);
5113 case KEY_sethostent:
5119 case KEY_setservent:
5122 case KEY_setprotoent:
5132 LOP(OP_SEEKDIR,XTERM);
5134 case KEY_setsockopt:
5135 LOP(OP_SSOCKOPT,XTERM);
5141 LOP(OP_SHMCTL,XTERM);
5144 LOP(OP_SHMGET,XTERM);
5147 LOP(OP_SHMREAD,XTERM);
5150 LOP(OP_SHMWRITE,XTERM);
5153 LOP(OP_SHUTDOWN,XTERM);
5162 LOP(OP_SOCKET,XTERM);
5164 case KEY_socketpair:
5165 LOP(OP_SOCKPAIR,XTERM);
5168 checkcomma(s,PL_tokenbuf,"subroutine name");
5170 if (*s == ';' || *s == ')') /* probably a close */
5171 Perl_croak(aTHX_ "sort is now a reserved word");
5173 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5177 LOP(OP_SPLIT,XTERM);
5180 LOP(OP_SPRINTF,XTERM);
5183 LOP(OP_SPLICE,XTERM);
5198 LOP(OP_SUBSTR,XTERM);
5204 char tmpbuf[sizeof PL_tokenbuf];
5205 SSize_t tboffset = 0;
5206 expectation attrful;
5207 bool have_name, have_proto, bad_proto;
5212 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5213 (*s == ':' && s[1] == ':'))
5216 attrful = XATTRBLOCK;
5217 /* remember buffer pos'n for later force_word */
5218 tboffset = s - PL_oldbufptr;
5219 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5220 if (strchr(tmpbuf, ':'))
5221 sv_setpv(PL_subname, tmpbuf);
5223 sv_setsv(PL_subname,PL_curstname);
5224 sv_catpvn(PL_subname,"::",2);
5225 sv_catpvn(PL_subname,tmpbuf,len);
5232 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5233 PL_expect = XTERMBLOCK;
5234 attrful = XATTRTERM;
5235 sv_setpv(PL_subname,"?");
5239 if (key == KEY_format) {
5241 PL_lex_formbrack = PL_lex_brackets + 1;
5243 (void) force_word(PL_oldbufptr + tboffset, WORD,
5248 /* Look for a prototype */
5252 s = scan_str(s,FALSE,FALSE);
5254 Perl_croak(aTHX_ "Prototype not terminated");
5255 /* strip spaces and check for bad characters */
5256 d = SvPVX(PL_lex_stuff);
5259 for (p = d; *p; ++p) {
5262 if (!strchr("$@%*;[]&\\", *p))
5267 if (bad_proto && ckWARN(WARN_SYNTAX))
5268 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5269 "Illegal character in prototype for %"SVf" : %s",
5271 SvCUR(PL_lex_stuff) = tmp;
5279 if (*s == ':' && s[1] != ':')
5280 PL_expect = attrful;
5281 else if (*s != '{' && key == KEY_sub) {
5283 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5285 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5289 PL_nextval[PL_nexttoke].opval =
5290 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5291 PL_lex_stuff = Nullsv;
5295 sv_setpv(PL_subname,
5296 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5299 (void) force_word(PL_oldbufptr + tboffset, WORD,
5308 LOP(OP_SYSTEM,XREF);
5311 LOP(OP_SYMLINK,XTERM);
5314 LOP(OP_SYSCALL,XTERM);
5317 LOP(OP_SYSOPEN,XTERM);
5320 LOP(OP_SYSSEEK,XTERM);
5323 LOP(OP_SYSREAD,XTERM);
5326 LOP(OP_SYSWRITE,XTERM);
5330 TERM(sublex_start());
5351 LOP(OP_TRUNCATE,XTERM);
5363 yylval.ival = CopLINE(PL_curcop);
5367 yylval.ival = CopLINE(PL_curcop);
5371 LOP(OP_UNLINK,XTERM);
5377 LOP(OP_UNPACK,XTERM);
5380 LOP(OP_UTIME,XTERM);
5386 LOP(OP_UNSHIFT,XTERM);
5389 if (PL_expect != XSTATE)
5390 yyerror("\"use\" not allowed in expression");
5392 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5393 s = force_version(s, TRUE);
5394 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5395 PL_nextval[PL_nexttoke].opval = Nullop;
5398 else if (*s == 'v') {
5399 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5400 s = force_version(s, FALSE);
5404 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5405 s = force_version(s, FALSE);
5417 yylval.ival = CopLINE(PL_curcop);
5421 PL_hints |= HINT_BLOCK_SCOPE;
5428 LOP(OP_WAITPID,XTERM);
5437 ctl_l[0] = toCTRL('L');
5439 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5442 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5447 if (PL_expect == XOPERATOR)
5453 yylval.ival = OP_XOR;
5458 TERM(sublex_start());
5463 #pragma segment Main
5467 S_pending_ident(pTHX)
5470 register I32 tmp = 0;
5471 /* pit holds the identifier we read and pending_ident is reset */
5472 char pit = PL_pending_ident;
5473 PL_pending_ident = 0;
5475 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5476 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5478 /* if we're in a my(), we can't allow dynamics here.
5479 $foo'bar has already been turned into $foo::bar, so
5480 just check for colons.
5482 if it's a legal name, the OP is a PADANY.
5485 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5486 if (strchr(PL_tokenbuf,':'))
5487 yyerror(Perl_form(aTHX_ "No package name allowed for "
5488 "variable %s in \"our\"",
5490 tmp = allocmy(PL_tokenbuf);
5493 if (strchr(PL_tokenbuf,':'))
5494 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5496 yylval.opval = newOP(OP_PADANY, 0);
5497 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5503 build the ops for accesses to a my() variable.
5505 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5506 then used in a comparison. This catches most, but not
5507 all cases. For instance, it catches
5508 sort { my($a); $a <=> $b }
5510 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5511 (although why you'd do that is anyone's guess).
5514 if (!strchr(PL_tokenbuf,':')) {
5516 tmp = pad_findmy(PL_tokenbuf);
5517 if (tmp != NOT_IN_PAD) {
5518 /* might be an "our" variable" */
5519 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5520 /* build ops for a bareword */
5521 SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0);
5522 sv_catpvn(sym, "::", 2);
5523 sv_catpv(sym, PL_tokenbuf+1);
5524 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5525 yylval.opval->op_private = OPpCONST_ENTERED;
5528 ? (GV_ADDMULTI | GV_ADDINEVAL)
5531 ((PL_tokenbuf[0] == '$') ? SVt_PV
5532 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5537 /* if it's a sort block and they're naming $a or $b */
5538 if (PL_last_lop_op == OP_SORT &&
5539 PL_tokenbuf[0] == '$' &&
5540 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5543 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5544 d < PL_bufend && *d != '\n';
5547 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5548 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5554 yylval.opval = newOP(OP_PADANY, 0);
5555 yylval.opval->op_targ = tmp;
5561 Whine if they've said @foo in a doublequoted string,
5562 and @foo isn't a variable we can find in the symbol
5565 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5566 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5567 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5568 && ckWARN(WARN_AMBIGUOUS))
5570 /* Downgraded from fatal to warning 20000522 mjd */
5571 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5572 "Possible unintended interpolation of %s in string",
5577 /* build ops for a bareword */
5578 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5579 yylval.opval->op_private = OPpCONST_ENTERED;
5580 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5581 ((PL_tokenbuf[0] == '$') ? SVt_PV
5582 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5588 * The following code was generated by perl_keyword.pl.
5592 Perl_keyword (pTHX_ char *name, I32 len)
5596 case 1: /* 5 tokens of length 1 */
5628 case 2: /* 18 tokens of length 2 */
5774 case 3: /* 28 tokens of length 3 */
5778 if (name[1] == 'N' &&
5841 if (name[1] == 'i' &&
5881 if (name[1] == 'o' &&
5890 if (name[1] == 'e' &&
5899 if (name[1] == 'n' &&
5908 if (name[1] == 'o' &&
5917 if (name[1] == 'a' &&
5926 if (name[1] == 'o' &&
5988 if (name[1] == 'e' &&
6020 if (name[1] == 'i' &&
6029 if (name[1] == 's' &&
6038 if (name[1] == 'e' &&
6047 if (name[1] == 'o' &&
6059 case 4: /* 40 tokens of length 4 */
6063 if (name[1] == 'O' &&
6073 if (name[1] == 'N' &&
6083 if (name[1] == 'i' &&
6093 if (name[1] == 'h' &&
6103 if (name[1] == 'u' &&
6116 if (name[2] == 'c' &&
6125 if (name[2] == 's' &&
6134 if (name[2] == 'a' &&
6170 if (name[1] == 'o' &&
6183 if (name[2] == 't' &&
6192 if (name[2] == 'o' &&
6201 if (name[2] == 't' &&
6210 if (name[2] == 'e' &&
6223 if (name[1] == 'o' &&
6236 if (name[2] == 'y' &&
6245 if (name[2] == 'l' &&
6261 if (name[2] == 's' &&
6270 if (name[2] == 'n' &&
6279 if (name[2] == 'c' &&
6292 if (name[1] == 'e' &&
6302 if (name[1] == 'p' &&
6315 if (name[2] == 'c' &&
6324 if (name[2] == 'p' &&
6333 if (name[2] == 's' &&
6349 if (name[2] == 'n' &&
6419 if (name[2] == 'r' &&
6428 if (name[2] == 'r' &&
6437 if (name[2] == 'a' &&
6453 if (name[2] == 'l' &&
6520 case 5: /* 36 tokens of length 5 */
6524 if (name[1] == 'E' &&
6535 if (name[1] == 'H' &&
6549 if (name[2] == 'a' &&
6559 if (name[2] == 'a' &&
6573 if (name[1] == 'l' &&
6590 if (name[3] == 'i' &&
6599 if (name[3] == 'o' &&
6635 if (name[2] == 'o' &&
6645 if (name[2] == 'y' &&
6659 if (name[1] == 'l' &&
6673 if (name[2] == 'n' &&
6683 if (name[2] == 'o' &&
6700 if (name[2] == 'd' &&
6710 if (name[2] == 'c' &&
6727 if (name[2] == 'c' &&
6737 if (name[2] == 't' &&
6751 if (name[1] == 'k' &&
6762 if (name[1] == 'r' &&
6776 if (name[2] == 's' &&
6786 if (name[2] == 'd' &&
6803 if (name[2] == 'm' &&
6813 if (name[2] == 'i' &&
6823 if (name[2] == 'e' &&
6833 if (name[2] == 'l' &&
6843 if (name[2] == 'a' &&
6853 if (name[2] == 'u' &&
6867 if (name[1] == 'i' &&
6881 if (name[2] == 'a' &&
6894 if (name[3] == 'e' &&
6929 if (name[2] == 'i' &&
6946 if (name[2] == 'i' &&
6956 if (name[2] == 'i' &&
6973 case 6: /* 33 tokens of length 6 */
6977 if (name[1] == 'c' &&
6992 if (name[2] == 'l' &&
7003 if (name[2] == 'r' &&
7018 if (name[1] == 'e' &&
7033 if (name[2] == 's' &&
7038 if(ckWARN_d(WARN_SYNTAX))
7039 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7045 if (name[2] == 'i' &&
7063 if (name[2] == 'l' &&
7074 if (name[2] == 'r' &&
7089 if (name[1] == 'm' &&
7104 if (name[2] == 'n' &&
7115 if (name[2] == 's' &&
7130 if (name[1] == 's' &&
7136 if (name[4] == 't' &&
7145 if (name[4] == 'e' &&
7154 if (name[4] == 'c' &&
7163 if (name[4] == 'n' &&
7179 if (name[1] == 'r' &&
7197 if (name[3] == 'a' &&
7207 if (name[3] == 'u' &&
7221 if (name[2] == 'n' &&
7239 if (name[2] == 'a' &&
7253 if (name[3] == 'e' &&
7266 if (name[4] == 't' &&
7275 if (name[4] == 'e' &&
7297 if (name[4] == 't' &&
7306 if (name[4] == 'e' &&
7322 if (name[2] == 'c' &&
7333 if (name[2] == 'l' &&
7344 if (name[2] == 'b' &&
7355 if (name[2] == 's' &&
7378 if (name[4] == 's' &&
7387 if (name[4] == 'n' &&
7400 if (name[3] == 'a' &&
7417 if (name[1] == 'a' &&
7432 case 7: /* 28 tokens of length 7 */
7436 if (name[1] == 'E' &&
7449 if (name[1] == '_' &&
7462 if (name[1] == 'i' &&
7469 return -KEY_binmode;
7475 if (name[1] == 'o' &&
7482 return -KEY_connect;
7491 if (name[2] == 'm' &&
7497 return -KEY_dbmopen;
7503 if (name[2] == 'f' &&
7519 if (name[1] == 'o' &&
7532 if (name[1] == 'e' &&
7539 if (name[5] == 'r' &&
7542 return -KEY_getpgrp;
7548 if (name[5] == 'i' &&
7551 return -KEY_getppid;
7564 if (name[1] == 'c' &&
7571 return -KEY_lcfirst;
7577 if (name[1] == 'p' &&
7584 return -KEY_opendir;
7590 if (name[1] == 'a' &&
7608 if (name[3] == 'd' &&
7613 return -KEY_readdir;
7619 if (name[3] == 'u' &&
7630 if (name[3] == 'e' &&
7635 return -KEY_reverse;
7654 if (name[3] == 'k' &&
7659 return -KEY_seekdir;
7665 if (name[3] == 'p' &&
7670 return -KEY_setpgrp;
7680 if (name[2] == 'm' &&
7686 return -KEY_shmread;
7692 if (name[2] == 'r' &&
7698 return -KEY_sprintf;
7707 if (name[3] == 'l' &&
7712 return -KEY_symlink;
7721 if (name[4] == 'a' &&
7725 return -KEY_syscall;
7731 if (name[4] == 'p' &&
7735 return -KEY_sysopen;
7741 if (name[4] == 'e' &&
7745 return -KEY_sysread;
7751 if (name[4] == 'e' &&
7755 return -KEY_sysseek;
7773 if (name[1] == 'e' &&
7780 return -KEY_telldir;
7789 if (name[2] == 'f' &&
7795 return -KEY_ucfirst;
7801 if (name[2] == 's' &&
7807 return -KEY_unshift;
7817 if (name[1] == 'a' &&
7824 return -KEY_waitpid;
7833 case 8: /* 26 tokens of length 8 */
7837 if (name[1] == 'U' &&
7845 return KEY_AUTOLOAD;
7856 if (name[3] == 'A' &&
7862 return KEY___DATA__;
7868 if (name[3] == 'I' &&
7874 return -KEY___FILE__;
7880 if (name[3] == 'I' &&
7886 return -KEY___LINE__;
7902 if (name[2] == 'o' &&
7909 return -KEY_closedir;
7915 if (name[2] == 'n' &&
7922 return -KEY_continue;
7932 if (name[1] == 'b' &&
7940 return -KEY_dbmclose;
7946 if (name[1] == 'n' &&
7952 if (name[4] == 'r' &&
7957 return -KEY_endgrent;
7963 if (name[4] == 'w' &&
7968 return -KEY_endpwent;
7981 if (name[1] == 'o' &&
7989 return -KEY_formline;
7995 if (name[1] == 'e' &&
8006 if (name[6] == 'n' &&
8009 return -KEY_getgrent;
8015 if (name[6] == 'i' &&
8018 return -KEY_getgrgid;
8024 if (name[6] == 'a' &&
8027 return -KEY_getgrnam;
8040 if (name[4] == 'o' &&
8045 return -KEY_getlogin;
8056 if (name[6] == 'n' &&
8059 return -KEY_getpwent;
8065 if (name[6] == 'a' &&
8068 return -KEY_getpwnam;
8074 if (name[6] == 'i' &&
8077 return -KEY_getpwuid;
8097 if (name[1] == 'e' &&
8104 if (name[5] == 'i' &&
8111 return -KEY_readline;
8116 return -KEY_readlink;
8127 if (name[5] == 'i' &&
8131 return -KEY_readpipe;
8152 if (name[4] == 'r' &&
8157 return -KEY_setgrent;
8163 if (name[4] == 'w' &&
8168 return -KEY_setpwent;
8184 if (name[3] == 'w' &&
8190 return -KEY_shmwrite;
8196 if (name[3] == 't' &&
8202 return -KEY_shutdown;
8212 if (name[2] == 's' &&
8219 return -KEY_syswrite;
8229 if (name[1] == 'r' &&
8237 return -KEY_truncate;
8246 case 9: /* 8 tokens of length 9 */
8250 if (name[1] == 'n' &&
8259 return -KEY_endnetent;
8265 if (name[1] == 'e' &&
8274 return -KEY_getnetent;
8280 if (name[1] == 'o' &&
8289 return -KEY_localtime;
8295 if (name[1] == 'r' &&
8304 return KEY_prototype;
8310 if (name[1] == 'u' &&
8319 return -KEY_quotemeta;
8325 if (name[1] == 'e' &&
8334 return -KEY_rewinddir;
8340 if (name[1] == 'e' &&
8349 return -KEY_setnetent;
8355 if (name[1] == 'a' &&
8364 return -KEY_wantarray;
8373 case 10: /* 9 tokens of length 10 */
8377 if (name[1] == 'n' &&
8383 if (name[4] == 'o' &&
8390 return -KEY_endhostent;
8396 if (name[4] == 'e' &&
8403 return -KEY_endservent;
8416 if (name[1] == 'e' &&
8422 if (name[4] == 'o' &&
8429 return -KEY_gethostent;
8438 if (name[5] == 'r' &&
8444 return -KEY_getservent;
8450 if (name[5] == 'c' &&
8456 return -KEY_getsockopt;
8481 if (name[4] == 'o' &&
8488 return -KEY_sethostent;
8497 if (name[5] == 'r' &&
8503 return -KEY_setservent;
8509 if (name[5] == 'c' &&
8515 return -KEY_setsockopt;
8532 if (name[2] == 'c' &&
8541 return -KEY_socketpair;
8554 case 11: /* 8 tokens of length 11 */
8558 if (name[1] == '_' &&
8569 return -KEY___PACKAGE__;
8575 if (name[1] == 'n' &&
8586 return -KEY_endprotoent;
8592 if (name[1] == 'e' &&
8601 if (name[5] == 'e' &&
8608 return -KEY_getpeername;
8617 if (name[6] == 'o' &&
8623 return -KEY_getpriority;
8629 if (name[6] == 't' &&
8635 return -KEY_getprotoent;
8649 if (name[4] == 'o' &&
8657 return -KEY_getsockname;
8670 if (name[1] == 'e' &&
8678 if (name[6] == 'o' &&
8684 return -KEY_setpriority;
8690 if (name[6] == 't' &&
8696 return -KEY_setprotoent;
8712 case 12: /* 2 tokens of length 12 */
8713 if (name[0] == 'g' &&
8725 if (name[9] == 'd' &&
8728 { /* getnetbyaddr */
8729 return -KEY_getnetbyaddr;
8735 if (name[9] == 'a' &&
8738 { /* getnetbyname */
8739 return -KEY_getnetbyname;
8751 case 13: /* 4 tokens of length 13 */
8752 if (name[0] == 'g' &&
8759 if (name[4] == 'o' &&
8768 if (name[10] == 'd' &&
8771 { /* gethostbyaddr */
8772 return -KEY_gethostbyaddr;
8778 if (name[10] == 'a' &&
8781 { /* gethostbyname */
8782 return -KEY_gethostbyname;
8795 if (name[4] == 'e' &&
8804 if (name[10] == 'a' &&
8807 { /* getservbyname */
8808 return -KEY_getservbyname;
8814 if (name[10] == 'o' &&
8817 { /* getservbyport */
8818 return -KEY_getservbyport;
8837 case 14: /* 1 tokens of length 14 */
8838 if (name[0] == 'g' &&
8852 { /* getprotobyname */
8853 return -KEY_getprotobyname;
8858 case 16: /* 1 tokens of length 16 */
8859 if (name[0] == 'g' &&
8875 { /* getprotobynumber */
8876 return -KEY_getprotobynumber;
8890 S_checkcomma(pTHX_ register char *s, char *name, char *what)
8894 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8895 if (ckWARN(WARN_SYNTAX)) {
8897 for (w = s+2; *w && level; w++) {
8904 for (; *w && isSPACE(*w); w++) ;
8905 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
8906 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8907 "%s (...) interpreted as function",name);
8910 while (s < PL_bufend && isSPACE(*s))
8914 while (s < PL_bufend && isSPACE(*s))
8916 if (isIDFIRST_lazy_if(s,UTF)) {
8918 while (isALNUM_lazy_if(s,UTF))
8920 while (s < PL_bufend && isSPACE(*s))
8925 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
8929 Perl_croak(aTHX_ "No comma allowed after %s", what);
8934 /* Either returns sv, or mortalizes sv and returns a new SV*.
8935 Best used as sv=new_constant(..., sv, ...).
8936 If s, pv are NULL, calls subroutine with one argument,
8937 and type is used with error messages only. */
8940 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
8944 HV *table = GvHV(PL_hintgv); /* ^H */
8948 const char *why1, *why2, *why3;
8950 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8953 why2 = strEQ(key,"charnames")
8954 ? "(possibly a missing \"use charnames ...\")"
8956 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
8957 (type ? type: "undef"), why2);
8959 /* This is convoluted and evil ("goto considered harmful")
8960 * but I do not understand the intricacies of all the different
8961 * failure modes of %^H in here. The goal here is to make
8962 * the most probable error message user-friendly. --jhi */
8967 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
8968 (type ? type: "undef"), why1, why2, why3);
8970 yyerror(SvPVX(msg));
8974 cvp = hv_fetch(table, key, strlen(key), FALSE);
8975 if (!cvp || !SvOK(*cvp)) {
8978 why3 = "} is not defined";
8981 sv_2mortal(sv); /* Parent created it permanently */
8984 pv = sv_2mortal(newSVpvn(s, len));
8986 typesv = sv_2mortal(newSVpv(type, 0));
8988 typesv = &PL_sv_undef;
8990 PUSHSTACKi(PERLSI_OVERLOAD);
9002 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9006 /* Check the eval first */
9007 if (!PL_in_eval && SvTRUE(ERRSV)) {
9009 sv_catpv(ERRSV, "Propagated");
9010 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
9012 res = SvREFCNT_inc(sv);
9016 (void)SvREFCNT_inc(res);
9025 why1 = "Call to &{$^H{";
9027 why3 = "}} did not return a defined value";
9035 /* Returns a NUL terminated string, with the length of the string written to
9039 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9041 register char *d = dest;
9042 register char *e = d + destlen - 3; /* two-character token, ending NUL */
9045 Perl_croak(aTHX_ ident_too_long);
9046 if (isALNUM(*s)) /* UTF handled below */
9048 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9053 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9057 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9058 char *t = s + UTF8SKIP(s);
9059 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9061 if (d + (t - s) > e)
9062 Perl_croak(aTHX_ ident_too_long);
9063 Copy(s, d, t - s, char);
9076 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
9086 e = d + destlen - 3; /* two-character token, ending NUL */
9088 while (isDIGIT(*s)) {
9090 Perl_croak(aTHX_ ident_too_long);
9097 Perl_croak(aTHX_ ident_too_long);
9098 if (isALNUM(*s)) /* UTF handled below */
9100 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9105 else if (*s == ':' && s[1] == ':') {
9109 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9110 char *t = s + UTF8SKIP(s);
9111 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9113 if (d + (t - s) > e)
9114 Perl_croak(aTHX_ ident_too_long);
9115 Copy(s, d, t - s, char);
9126 if (PL_lex_state != LEX_NORMAL)
9127 PL_lex_state = LEX_INTERPENDMAYBE;
9130 if (*s == '$' && s[1] &&
9131 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9144 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9149 if (isSPACE(s[-1])) {
9152 if (!SPACE_OR_TAB(ch)) {
9158 if (isIDFIRST_lazy_if(d,UTF)) {
9162 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9164 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9167 Copy(s, d, e - s, char);
9172 while ((isALNUM(*s) || *s == ':') && d < e)
9175 Perl_croak(aTHX_ ident_too_long);
9178 while (s < send && SPACE_OR_TAB(*s)) s++;
9179 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9180 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9181 const char *brack = *s == '[' ? "[...]" : "{...}";
9182 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9183 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9184 funny, dest, brack, funny, dest, brack);
9187 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9191 /* Handle extended ${^Foo} variables
9192 * 1999-02-27 mjd-perl-patch@plover.com */
9193 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9197 while (isALNUM(*s) && d < e) {
9201 Perl_croak(aTHX_ ident_too_long);
9206 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9207 PL_lex_state = LEX_INTERPEND;
9212 if (PL_lex_state == LEX_NORMAL) {
9213 if (ckWARN(WARN_AMBIGUOUS) &&
9214 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9216 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9217 "Ambiguous use of %c{%s} resolved to %c%s",
9218 funny, dest, funny, dest);
9223 s = bracket; /* let the parser handle it */
9227 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9228 PL_lex_state = LEX_INTERPEND;
9233 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9238 *pmfl |= PMf_GLOBAL;
9240 *pmfl |= PMf_CONTINUE;
9244 *pmfl |= PMf_MULTILINE;
9246 *pmfl |= PMf_SINGLELINE;
9248 *pmfl |= PMf_EXTENDED;
9252 S_scan_pat(pTHX_ char *start, I32 type)
9257 s = scan_str(start,FALSE,FALSE);
9259 Perl_croak(aTHX_ "Search pattern not terminated");
9261 pm = (PMOP*)newPMOP(type, 0);
9262 if (PL_multi_open == '?')
9263 pm->op_pmflags |= PMf_ONCE;
9265 while (*s && strchr("iomsx", *s))
9266 pmflag(&pm->op_pmflags,*s++);
9269 while (*s && strchr("iogcmsx", *s))
9270 pmflag(&pm->op_pmflags,*s++);
9272 /* issue a warning if /c is specified,but /g is not */
9273 if (ckWARN(WARN_REGEXP) &&
9274 (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9276 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
9279 pm->op_pmpermflags = pm->op_pmflags;
9281 PL_lex_op = (OP*)pm;
9282 yylval.ival = OP_MATCH;
9287 S_scan_subst(pTHX_ char *start)
9294 yylval.ival = OP_NULL;
9296 s = scan_str(start,FALSE,FALSE);
9299 Perl_croak(aTHX_ "Substitution pattern not terminated");
9301 if (s[-1] == PL_multi_open)
9304 first_start = PL_multi_start;
9305 s = scan_str(s,FALSE,FALSE);
9308 SvREFCNT_dec(PL_lex_stuff);
9309 PL_lex_stuff = Nullsv;
9311 Perl_croak(aTHX_ "Substitution replacement not terminated");
9313 PL_multi_start = first_start; /* so whole substitution is taken together */
9315 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9321 else if (strchr("iogcmsx", *s))
9322 pmflag(&pm->op_pmflags,*s++);
9327 /* /c is not meaningful with s/// */
9328 if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
9330 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
9335 PL_sublex_info.super_bufptr = s;
9336 PL_sublex_info.super_bufend = PL_bufend;
9338 pm->op_pmflags |= PMf_EVAL;
9339 repl = newSVpvn("",0);
9341 sv_catpv(repl, es ? "eval " : "do ");
9342 sv_catpvn(repl, "{ ", 2);
9343 sv_catsv(repl, PL_lex_repl);
9344 sv_catpvn(repl, " };", 2);
9346 SvREFCNT_dec(PL_lex_repl);
9350 pm->op_pmpermflags = pm->op_pmflags;
9351 PL_lex_op = (OP*)pm;
9352 yylval.ival = OP_SUBST;
9357 S_scan_trans(pTHX_ char *start)
9366 yylval.ival = OP_NULL;
9368 s = scan_str(start,FALSE,FALSE);
9370 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9371 if (s[-1] == PL_multi_open)
9374 s = scan_str(s,FALSE,FALSE);
9377 SvREFCNT_dec(PL_lex_stuff);
9378 PL_lex_stuff = Nullsv;
9380 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9383 complement = del = squash = 0;
9387 complement = OPpTRANS_COMPLEMENT;
9390 del = OPpTRANS_DELETE;
9393 squash = OPpTRANS_SQUASH;
9402 New(803, tbl, complement&&!del?258:256, short);
9403 o = newPVOP(OP_TRANS, 0, (char*)tbl);
9404 o->op_private &= ~OPpTRANS_ALL;
9405 o->op_private |= del|squash|complement|
9406 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9407 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9410 yylval.ival = OP_TRANS;
9415 S_scan_heredoc(pTHX_ register char *s)
9418 I32 op_type = OP_SCALAR;
9425 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9429 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9432 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9433 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9436 s = delimcpy(d, e, s, PL_bufend, term, &len);
9446 if (!isALNUM_lazy_if(s,UTF))
9447 deprecate_old("bare << to mean <<\"\"");
9448 for (; isALNUM_lazy_if(s,UTF); s++) {
9453 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9454 Perl_croak(aTHX_ "Delimiter for here document is too long");
9457 len = d - PL_tokenbuf;
9458 #ifndef PERL_STRICT_CR
9459 d = strchr(s, '\r');
9463 while (s < PL_bufend) {
9469 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9478 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
9483 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
9484 herewas = newSVpvn(s,PL_bufend-s);
9486 s--, herewas = newSVpvn(s,d-s);
9487 s += SvCUR(herewas);
9489 tmpstr = NEWSV(87,79);
9490 sv_upgrade(tmpstr, SVt_PVIV);
9495 else if (term == '`') {
9496 op_type = OP_BACKTICK;
9497 SvIVX(tmpstr) = '\\';
9501 PL_multi_start = CopLINE(PL_curcop);
9502 PL_multi_open = PL_multi_close = '<';
9503 term = *PL_tokenbuf;
9504 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9505 char *bufptr = PL_sublex_info.super_bufptr;
9506 char *bufend = PL_sublex_info.super_bufend;
9507 char *olds = s - SvCUR(herewas);
9508 s = strchr(bufptr, '\n');
9512 while (s < bufend &&
9513 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9515 CopLINE_inc(PL_curcop);
9518 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9519 missingterm(PL_tokenbuf);
9521 sv_setpvn(herewas,bufptr,d-bufptr+1);
9522 sv_setpvn(tmpstr,d+1,s-d);
9524 sv_catpvn(herewas,s,bufend-s);
9525 Copy(SvPVX(herewas),bufptr,SvCUR(herewas) + 1,char);
9532 while (s < PL_bufend &&
9533 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9535 CopLINE_inc(PL_curcop);
9537 if (s >= PL_bufend) {
9538 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9539 missingterm(PL_tokenbuf);
9541 sv_setpvn(tmpstr,d+1,s-d);
9543 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9545 sv_catpvn(herewas,s,PL_bufend-s);
9546 sv_setsv(PL_linestr,herewas);
9547 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9548 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9549 PL_last_lop = PL_last_uni = Nullch;
9552 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
9553 while (s >= PL_bufend) { /* multiple line string? */
9555 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9556 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9557 missingterm(PL_tokenbuf);
9559 CopLINE_inc(PL_curcop);
9560 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9561 PL_last_lop = PL_last_uni = Nullch;
9562 #ifndef PERL_STRICT_CR
9563 if (PL_bufend - PL_linestart >= 2) {
9564 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9565 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9567 PL_bufend[-2] = '\n';
9569 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
9571 else if (PL_bufend[-1] == '\r')
9572 PL_bufend[-1] = '\n';
9574 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9575 PL_bufend[-1] = '\n';
9577 if (PERLDB_LINE && PL_curstash != PL_debstash) {
9578 SV *sv = NEWSV(88,0);
9580 sv_upgrade(sv, SVt_PVMG);
9581 sv_setsv(sv,PL_linestr);
9584 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9586 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9587 STRLEN off = PL_bufend - 1 - SvPVX(PL_linestr);
9588 *(SvPVX(PL_linestr) + off ) = ' ';
9589 sv_catsv(PL_linestr,herewas);
9590 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9591 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9595 sv_catsv(tmpstr,PL_linestr);
9600 PL_multi_end = CopLINE(PL_curcop);
9601 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9602 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
9603 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
9605 SvREFCNT_dec(herewas);
9607 if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
9609 else if (PL_encoding)
9610 sv_recode_to_utf8(tmpstr, PL_encoding);
9612 PL_lex_stuff = tmpstr;
9613 yylval.ival = op_type;
9618 takes: current position in input buffer
9619 returns: new position in input buffer
9620 side-effects: yylval and lex_op are set.
9625 <FH> read from filehandle
9626 <pkg::FH> read from package qualified filehandle
9627 <pkg'FH> read from package qualified filehandle
9628 <$fh> read from filehandle in $fh
9634 S_scan_inputsymbol(pTHX_ char *start)
9636 register char *s = start; /* current position in buffer */
9642 d = PL_tokenbuf; /* start of temp holding space */
9643 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9644 end = strchr(s, '\n');
9647 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9649 /* die if we didn't have space for the contents of the <>,
9650 or if it didn't end, or if we see a newline
9653 if (len >= sizeof PL_tokenbuf)
9654 Perl_croak(aTHX_ "Excessively long <> operator");
9656 Perl_croak(aTHX_ "Unterminated <> operator");
9661 Remember, only scalar variables are interpreted as filehandles by
9662 this code. Anything more complex (e.g., <$fh{$num}>) will be
9663 treated as a glob() call.
9664 This code makes use of the fact that except for the $ at the front,
9665 a scalar variable and a filehandle look the same.
9667 if (*d == '$' && d[1]) d++;
9669 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9670 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9673 /* If we've tried to read what we allow filehandles to look like, and
9674 there's still text left, then it must be a glob() and not a getline.
9675 Use scan_str to pull out the stuff between the <> and treat it
9676 as nothing more than a string.
9679 if (d - PL_tokenbuf != len) {
9680 yylval.ival = OP_GLOB;
9682 s = scan_str(start,FALSE,FALSE);
9684 Perl_croak(aTHX_ "Glob not terminated");
9688 bool readline_overriden = FALSE;
9689 GV *gv_readline = Nullgv;
9691 /* we're in a filehandle read situation */
9694 /* turn <> into <ARGV> */
9696 Copy("ARGV",d,5,char);
9698 /* Check whether readline() is overriden */
9699 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9700 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9702 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9703 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9704 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9705 readline_overriden = TRUE;
9707 /* if <$fh>, create the ops to turn the variable into a
9713 /* try to find it in the pad for this block, otherwise find
9714 add symbol table ops
9716 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9717 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9718 SV *sym = sv_2mortal(
9719 newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0));
9720 sv_catpvn(sym, "::", 2);
9726 OP *o = newOP(OP_PADSV, 0);
9728 PL_lex_op = readline_overriden
9729 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9730 append_elem(OP_LIST, o,
9731 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9732 : (OP*)newUNOP(OP_READLINE, 0, o);
9741 ? (GV_ADDMULTI | GV_ADDINEVAL)
9744 PL_lex_op = readline_overriden
9745 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9746 append_elem(OP_LIST,
9747 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9748 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9749 : (OP*)newUNOP(OP_READLINE, 0,
9750 newUNOP(OP_RV2SV, 0,
9751 newGVOP(OP_GV, 0, gv)));
9753 if (!readline_overriden)
9754 PL_lex_op->op_flags |= OPf_SPECIAL;
9755 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9756 yylval.ival = OP_NULL;
9759 /* If it's none of the above, it must be a literal filehandle
9760 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9762 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9763 PL_lex_op = readline_overriden
9764 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9765 append_elem(OP_LIST,
9766 newGVOP(OP_GV, 0, gv),
9767 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9768 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9769 yylval.ival = OP_NULL;
9778 takes: start position in buffer
9779 keep_quoted preserve \ on the embedded delimiter(s)
9780 keep_delims preserve the delimiters around the string
9781 returns: position to continue reading from buffer
9782 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9783 updates the read buffer.
9785 This subroutine pulls a string out of the input. It is called for:
9786 q single quotes q(literal text)
9787 ' single quotes 'literal text'
9788 qq double quotes qq(interpolate $here please)
9789 " double quotes "interpolate $here please"
9790 qx backticks qx(/bin/ls -l)
9791 ` backticks `/bin/ls -l`
9792 qw quote words @EXPORT_OK = qw( func() $spam )
9793 m// regexp match m/this/
9794 s/// regexp substitute s/this/that/
9795 tr/// string transliterate tr/this/that/
9796 y/// string transliterate y/this/that/
9797 ($*@) sub prototypes sub foo ($)
9798 (stuff) sub attr parameters sub foo : attr(stuff)
9799 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9801 In most of these cases (all but <>, patterns and transliterate)
9802 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9803 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9804 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9807 It skips whitespace before the string starts, and treats the first
9808 character as the delimiter. If the delimiter is one of ([{< then
9809 the corresponding "close" character )]}> is used as the closing
9810 delimiter. It allows quoting of delimiters, and if the string has
9811 balanced delimiters ([{<>}]) it allows nesting.
9813 On success, the SV with the resulting string is put into lex_stuff or,
9814 if that is already non-NULL, into lex_repl. The second case occurs only
9815 when parsing the RHS of the special constructs s/// and tr/// (y///).
9816 For convenience, the terminating delimiter character is stuffed into
9821 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9823 SV *sv; /* scalar value: string */
9824 char *tmps; /* temp string, used for delimiter matching */
9825 register char *s = start; /* current position in the buffer */
9826 register char term; /* terminating character */
9827 register char *to; /* current position in the sv's data */
9828 I32 brackets = 1; /* bracket nesting level */
9829 bool has_utf8 = FALSE; /* is there any utf8 content? */
9830 I32 termcode; /* terminating char. code */
9831 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9832 STRLEN termlen; /* length of terminating string */
9833 char *last = NULL; /* last position for nesting bracket */
9835 /* skip space before the delimiter */
9839 /* mark where we are, in case we need to report errors */
9842 /* after skipping whitespace, the next character is the terminator */
9845 termcode = termstr[0] = term;
9849 termcode = utf8_to_uvchr((U8*)s, &termlen);
9850 Copy(s, termstr, termlen, U8);
9851 if (!UTF8_IS_INVARIANT(term))
9855 /* mark where we are */
9856 PL_multi_start = CopLINE(PL_curcop);
9857 PL_multi_open = term;
9859 /* find corresponding closing delimiter */
9860 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9861 termcode = termstr[0] = term = tmps[5];
9863 PL_multi_close = term;
9865 /* create a new SV to hold the contents. 87 is leak category, I'm
9866 assuming. 79 is the SV's initial length. What a random number. */
9868 sv_upgrade(sv, SVt_PVIV);
9869 SvIVX(sv) = termcode;
9870 (void)SvPOK_only(sv); /* validate pointer */
9872 /* move past delimiter and try to read a complete string */
9874 sv_catpvn(sv, s, termlen);
9877 if (PL_encoding && !UTF) {
9881 int offset = s - SvPVX(PL_linestr);
9882 bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9883 &offset, (char*)termstr, termlen);
9884 char *ns = SvPVX(PL_linestr) + offset;
9885 char *svlast = SvEND(sv) - 1;
9887 for (; s < ns; s++) {
9888 if (*s == '\n' && !PL_rsfp)
9889 CopLINE_inc(PL_curcop);
9892 goto read_more_line;
9894 /* handle quoted delimiters */
9895 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9897 for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';)
9899 if ((svlast-1 - t) % 2) {
9903 SvCUR_set(sv, SvCUR(sv) - 1);
9908 if (PL_multi_open == PL_multi_close) {
9915 for (w = t = last; t < svlast; w++, t++) {
9916 /* At here, all closes are "was quoted" one,
9917 so we don't check PL_multi_close. */
9919 if (!keep_quoted && *(t+1) == PL_multi_open)
9924 else if (*t == PL_multi_open)
9932 SvCUR_set(sv, w - SvPVX(sv));
9935 if (--brackets <= 0)
9941 SvCUR_set(sv, SvCUR(sv) - 1);
9947 /* extend sv if need be */
9948 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9949 /* set 'to' to the next character in the sv's string */
9950 to = SvPVX(sv)+SvCUR(sv);
9952 /* if open delimiter is the close delimiter read unbridle */
9953 if (PL_multi_open == PL_multi_close) {
9954 for (; s < PL_bufend; s++,to++) {
9955 /* embedded newlines increment the current line number */
9956 if (*s == '\n' && !PL_rsfp)
9957 CopLINE_inc(PL_curcop);
9958 /* handle quoted delimiters */
9959 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9960 if (!keep_quoted && s[1] == term)
9962 /* any other quotes are simply copied straight through */
9966 /* terminate when run out of buffer (the for() condition), or
9967 have found the terminator */
9968 else if (*s == term) {
9971 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9974 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9980 /* if the terminator isn't the same as the start character (e.g.,
9981 matched brackets), we have to allow more in the quoting, and
9982 be prepared for nested brackets.
9985 /* read until we run out of string, or we find the terminator */
9986 for (; s < PL_bufend; s++,to++) {
9987 /* embedded newlines increment the line count */
9988 if (*s == '\n' && !PL_rsfp)
9989 CopLINE_inc(PL_curcop);
9990 /* backslashes can escape the open or closing characters */
9991 if (*s == '\\' && s+1 < PL_bufend) {
9993 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9998 /* allow nested opens and closes */
9999 else if (*s == PL_multi_close && --brackets <= 0)
10001 else if (*s == PL_multi_open)
10003 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10008 /* terminate the copied string and update the sv's end-of-string */
10010 SvCUR_set(sv, to - SvPVX(sv));
10013 * this next chunk reads more into the buffer if we're not done yet
10017 break; /* handle case where we are done yet :-) */
10019 #ifndef PERL_STRICT_CR
10020 if (to - SvPVX(sv) >= 2) {
10021 if ((to[-2] == '\r' && to[-1] == '\n') ||
10022 (to[-2] == '\n' && to[-1] == '\r'))
10026 SvCUR_set(sv, to - SvPVX(sv));
10028 else if (to[-1] == '\r')
10031 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
10036 /* if we're out of file, or a read fails, bail and reset the current
10037 line marker so we can report where the unterminated string began
10040 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10042 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10045 /* we read a line, so increment our line counter */
10046 CopLINE_inc(PL_curcop);
10048 /* update debugger info */
10049 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10050 SV *sv = NEWSV(88,0);
10052 sv_upgrade(sv, SVt_PVMG);
10053 sv_setsv(sv,PL_linestr);
10054 (void)SvIOK_on(sv);
10056 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10059 /* having changed the buffer, we must update PL_bufend */
10060 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10061 PL_last_lop = PL_last_uni = Nullch;
10064 /* at this point, we have successfully read the delimited string */
10066 if (!PL_encoding || UTF) {
10068 sv_catpvn(sv, s, termlen);
10071 if (has_utf8 || PL_encoding)
10074 PL_multi_end = CopLINE(PL_curcop);
10076 /* if we allocated too much space, give some back */
10077 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10078 SvLEN_set(sv, SvCUR(sv) + 1);
10079 Renew(SvPVX(sv), SvLEN(sv), char);
10082 /* decide whether this is the first or second quoted string we've read
10095 takes: pointer to position in buffer
10096 returns: pointer to new position in buffer
10097 side-effects: builds ops for the constant in yylval.op
10099 Read a number in any of the formats that Perl accepts:
10101 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10102 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10105 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10107 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10110 If it reads a number without a decimal point or an exponent, it will
10111 try converting the number to an integer and see if it can do so
10112 without loss of precision.
10116 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
10118 register char *s = start; /* current position in buffer */
10119 register char *d; /* destination in temp buffer */
10120 register char *e; /* end of temp buffer */
10121 NV nv; /* number read, as a double */
10122 SV *sv = Nullsv; /* place to put the converted number */
10123 bool floatit; /* boolean: int or float? */
10124 char *lastub = 0; /* position of last underbar */
10125 static char number_too_long[] = "Number too long";
10127 /* We use the first character to decide what type of number this is */
10131 Perl_croak(aTHX_ "panic: scan_num");
10133 /* if it starts with a 0, it could be an octal number, a decimal in
10134 0.13 disguise, or a hexadecimal number, or a binary number. */
10138 u holds the "number so far"
10139 shift the power of 2 of the base
10140 (hex == 4, octal == 3, binary == 1)
10141 overflowed was the number more than we can hold?
10143 Shift is used when we add a digit. It also serves as an "are
10144 we in octal/hex/binary?" indicator to disallow hex characters
10145 when in octal mode.
10150 bool overflowed = FALSE;
10151 bool just_zero = TRUE; /* just plain 0 or binary number? */
10152 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10153 static char* bases[5] = { "", "binary", "", "octal",
10155 static char* Bases[5] = { "", "Binary", "", "Octal",
10157 static char *maxima[5] = { "",
10158 "0b11111111111111111111111111111111",
10162 char *base, *Base, *max;
10164 /* check for hex */
10169 } else if (s[1] == 'b') {
10174 /* check for a decimal in disguise */
10175 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10177 /* so it must be octal */
10184 if (ckWARN(WARN_SYNTAX))
10185 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10186 "Misplaced _ in number");
10190 base = bases[shift];
10191 Base = Bases[shift];
10192 max = maxima[shift];
10194 /* read the rest of the number */
10196 /* x is used in the overflow test,
10197 b is the digit we're adding on. */
10202 /* if we don't mention it, we're done */
10206 /* _ are ignored -- but warned about if consecutive */
10208 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
10209 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10210 "Misplaced _ in number");
10214 /* 8 and 9 are not octal */
10215 case '8': case '9':
10217 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10221 case '2': case '3': case '4':
10222 case '5': case '6': case '7':
10224 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10227 case '0': case '1':
10228 b = *s++ & 15; /* ASCII digit -> value of digit */
10232 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10233 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10234 /* make sure they said 0x */
10237 b = (*s++ & 7) + 9;
10239 /* Prepare to put the digit we have onto the end
10240 of the number so far. We check for overflows.
10246 x = u << shift; /* make room for the digit */
10248 if ((x >> shift) != u
10249 && !(PL_hints & HINT_NEW_BINARY)) {
10252 if (ckWARN_d(WARN_OVERFLOW))
10253 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10254 "Integer overflow in %s number",
10257 u = x | b; /* add the digit to the end */
10260 n *= nvshift[shift];
10261 /* If an NV has not enough bits in its
10262 * mantissa to represent an UV this summing of
10263 * small low-order numbers is a waste of time
10264 * (because the NV cannot preserve the
10265 * low-order bits anyway): we could just
10266 * remember when did we overflow and in the
10267 * end just multiply n by the right
10275 /* if we get here, we had success: make a scalar value from
10280 /* final misplaced underbar check */
10281 if (s[-1] == '_') {
10282 if (ckWARN(WARN_SYNTAX))
10283 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10288 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
10289 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10290 "%s number > %s non-portable",
10296 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
10297 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10298 "%s number > %s non-portable",
10303 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10304 sv = new_constant(start, s - start, "integer",
10306 else if (PL_hints & HINT_NEW_BINARY)
10307 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10312 handle decimal numbers.
10313 we're also sent here when we read a 0 as the first digit
10315 case '1': case '2': case '3': case '4': case '5':
10316 case '6': case '7': case '8': case '9': case '.':
10319 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10322 /* read next group of digits and _ and copy into d */
10323 while (isDIGIT(*s) || *s == '_') {
10324 /* skip underscores, checking for misplaced ones
10328 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
10329 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10330 "Misplaced _ in number");
10334 /* check for end of fixed-length buffer */
10336 Perl_croak(aTHX_ number_too_long);
10337 /* if we're ok, copy the character */
10342 /* final misplaced underbar check */
10343 if (lastub && s == lastub + 1) {
10344 if (ckWARN(WARN_SYNTAX))
10345 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10348 /* read a decimal portion if there is one. avoid
10349 3..5 being interpreted as the number 3. followed
10352 if (*s == '.' && s[1] != '.') {
10357 if (ckWARN(WARN_SYNTAX))
10358 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10359 "Misplaced _ in number");
10363 /* copy, ignoring underbars, until we run out of digits.
10365 for (; isDIGIT(*s) || *s == '_'; s++) {
10366 /* fixed length buffer check */
10368 Perl_croak(aTHX_ number_too_long);
10370 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
10371 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10372 "Misplaced _ in number");
10378 /* fractional part ending in underbar? */
10379 if (s[-1] == '_') {
10380 if (ckWARN(WARN_SYNTAX))
10381 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10382 "Misplaced _ in number");
10384 if (*s == '.' && isDIGIT(s[1])) {
10385 /* oops, it's really a v-string, but without the "v" */
10391 /* read exponent part, if present */
10392 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10396 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10397 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10399 /* stray preinitial _ */
10401 if (ckWARN(WARN_SYNTAX))
10402 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10403 "Misplaced _ in number");
10407 /* allow positive or negative exponent */
10408 if (*s == '+' || *s == '-')
10411 /* stray initial _ */
10413 if (ckWARN(WARN_SYNTAX))
10414 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10415 "Misplaced _ in number");
10419 /* read digits of exponent */
10420 while (isDIGIT(*s) || *s == '_') {
10423 Perl_croak(aTHX_ number_too_long);
10427 if (ckWARN(WARN_SYNTAX) &&
10428 ((lastub && s == lastub + 1) ||
10429 (!isDIGIT(s[1]) && s[1] != '_')))
10430 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10431 "Misplaced _ in number");
10438 /* make an sv from the string */
10442 We try to do an integer conversion first if no characters
10443 indicating "float" have been found.
10448 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10450 if (flags == IS_NUMBER_IN_UV) {
10452 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10455 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10456 if (uv <= (UV) IV_MIN)
10457 sv_setiv(sv, -(IV)uv);
10464 /* terminate the string */
10466 nv = Atof(PL_tokenbuf);
10470 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10471 (PL_hints & HINT_NEW_INTEGER) )
10472 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10473 (floatit ? "float" : "integer"),
10477 /* if it starts with a v, it could be a v-string */
10480 sv = NEWSV(92,5); /* preallocate storage space */
10481 s = scan_vstring(s,sv);
10485 /* make the op for the constant and return */
10488 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10490 lvalp->opval = Nullop;
10496 S_scan_formline(pTHX_ register char *s)
10498 register char *eol;
10500 SV *stuff = newSVpvn("",0);
10501 bool needargs = FALSE;
10502 bool eofmt = FALSE;
10504 while (!needargs) {
10507 #ifdef PERL_STRICT_CR
10508 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10510 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10512 if (*t == '\n' || t == PL_bufend) {
10517 if (PL_in_eval && !PL_rsfp) {
10518 eol = memchr(s,'\n',PL_bufend-s);
10523 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10525 for (t = s; t < eol; t++) {
10526 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10528 goto enough; /* ~~ must be first line in formline */
10530 if (*t == '@' || *t == '^')
10534 sv_catpvn(stuff, s, eol-s);
10535 #ifndef PERL_STRICT_CR
10536 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10537 char *end = SvPVX(stuff) + SvCUR(stuff);
10549 s = filter_gets(PL_linestr, PL_rsfp, 0);
10550 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10551 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10552 PL_last_lop = PL_last_uni = Nullch;
10561 if (SvCUR(stuff)) {
10564 PL_lex_state = LEX_NORMAL;
10565 PL_nextval[PL_nexttoke].ival = 0;
10569 PL_lex_state = LEX_FORMLINE;
10571 if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff)))
10573 else if (PL_encoding)
10574 sv_recode_to_utf8(stuff, PL_encoding);
10576 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10578 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10582 SvREFCNT_dec(stuff);
10584 PL_lex_formbrack = 0;
10595 PL_cshlen = strlen(PL_cshname);
10600 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10602 I32 oldsavestack_ix = PL_savestack_ix;
10603 CV* outsidecv = PL_compcv;
10606 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10608 SAVEI32(PL_subline);
10609 save_item(PL_subname);
10610 SAVESPTR(PL_compcv);
10612 PL_compcv = (CV*)NEWSV(1104,0);
10613 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10614 CvFLAGS(PL_compcv) |= flags;
10616 PL_subline = CopLINE(PL_curcop);
10617 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10618 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10619 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10621 return oldsavestack_ix;
10625 #pragma segment Perl_yylex
10628 Perl_yywarn(pTHX_ char *s)
10630 PL_in_eval |= EVAL_WARNONLY;
10632 PL_in_eval &= ~EVAL_WARNONLY;
10637 Perl_yyerror(pTHX_ char *s)
10639 char *where = NULL;
10640 char *context = NULL;
10644 if (!yychar || (yychar == ';' && !PL_rsfp))
10646 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
10647 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
10650 The code below is removed for NetWare because it abends/crashes on NetWare
10651 when the script has error such as not having the closing quotes like:
10652 if ($var eq "value)
10653 Checking of white spaces is anyway done in NetWare code.
10656 while (isSPACE(*PL_oldoldbufptr))
10659 context = PL_oldoldbufptr;
10660 contlen = PL_bufptr - PL_oldoldbufptr;
10662 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
10663 PL_oldbufptr != PL_bufptr) {
10666 The code below is removed for NetWare because it abends/crashes on NetWare
10667 when the script has error such as not having the closing quotes like:
10668 if ($var eq "value)
10669 Checking of white spaces is anyway done in NetWare code.
10672 while (isSPACE(*PL_oldbufptr))
10675 context = PL_oldbufptr;
10676 contlen = PL_bufptr - PL_oldbufptr;
10678 else if (yychar > 255)
10679 where = "next token ???";
10680 else if (yychar == -2) { /* YYEMPTY */
10681 if (PL_lex_state == LEX_NORMAL ||
10682 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10683 where = "at end of line";
10684 else if (PL_lex_inpat)
10685 where = "within pattern";
10687 where = "within string";
10690 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10692 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10693 else if (isPRINT_LC(yychar))
10694 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10696 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10697 where = SvPVX(where_sv);
10699 msg = sv_2mortal(newSVpv(s, 0));
10700 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10701 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10703 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10705 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10706 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10707 Perl_sv_catpvf(aTHX_ msg,
10708 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10709 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10712 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10713 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10716 if (PL_error_count >= 10) {
10717 if (PL_in_eval && SvCUR(ERRSV))
10718 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10719 ERRSV, OutCopFILE(PL_curcop));
10721 Perl_croak(aTHX_ "%s has too many errors.\n",
10722 OutCopFILE(PL_curcop));
10725 PL_in_my_stash = Nullhv;
10729 #pragma segment Main
10733 S_swallow_bom(pTHX_ U8 *s)
10736 slen = SvCUR(PL_linestr);
10739 if (s[1] == 0xFE) {
10740 /* UTF-16 little-endian? (or UTF32-LE?) */
10741 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10742 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10743 #ifndef PERL_NO_UTF16_FILTER
10744 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10747 if (PL_bufend > (char*)s) {
10751 filter_add(utf16rev_textfilter, NULL);
10752 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10753 utf16_to_utf8_reversed(s, news,
10754 PL_bufend - (char*)s - 1,
10756 sv_setpvn(PL_linestr, (const char*)news, newlen);
10758 SvUTF8_on(PL_linestr);
10759 s = (U8*)SvPVX(PL_linestr);
10760 PL_bufend = SvPVX(PL_linestr) + newlen;
10763 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10768 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10769 #ifndef PERL_NO_UTF16_FILTER
10770 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10773 if (PL_bufend > (char *)s) {
10777 filter_add(utf16_textfilter, NULL);
10778 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10779 utf16_to_utf8(s, news,
10780 PL_bufend - (char*)s,
10782 sv_setpvn(PL_linestr, (const char*)news, newlen);
10784 SvUTF8_on(PL_linestr);
10785 s = (U8*)SvPVX(PL_linestr);
10786 PL_bufend = SvPVX(PL_linestr) + newlen;
10789 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
10794 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10795 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10796 s += 3; /* UTF-8 */
10802 if (s[2] == 0xFE && s[3] == 0xFF) {
10803 /* UTF-32 big-endian */
10804 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
10807 else if (s[2] == 0 && s[3] != 0) {
10810 * are a good indicator of UTF-16BE. */
10811 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10816 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10819 * are a good indicator of UTF-16LE. */
10820 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10829 * Restore a source filter.
10833 restore_rsfp(pTHX_ void *f)
10835 PerlIO *fp = (PerlIO*)f;
10837 if (PL_rsfp == PerlIO_stdin())
10838 PerlIO_clearerr(PL_rsfp);
10839 else if (PL_rsfp && (PL_rsfp != fp))
10840 PerlIO_close(PL_rsfp);
10844 #ifndef PERL_NO_UTF16_FILTER
10846 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10848 STRLEN old = SvCUR(sv);
10849 I32 count = FILTER_READ(idx+1, sv, maxlen);
10850 DEBUG_P(PerlIO_printf(Perl_debug_log,
10851 "utf16_textfilter(%p): %d %d (%d)\n",
10852 utf16_textfilter, idx, maxlen, (int) count));
10856 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10857 Copy(SvPVX(sv), tmps, old, char);
10858 utf16_to_utf8((U8*)SvPVX(sv) + old, tmps + old,
10859 SvCUR(sv) - old, &newlen);
10860 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10862 DEBUG_P({sv_dump(sv);});
10867 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10869 STRLEN old = SvCUR(sv);
10870 I32 count = FILTER_READ(idx+1, sv, maxlen);
10871 DEBUG_P(PerlIO_printf(Perl_debug_log,
10872 "utf16rev_textfilter(%p): %d %d (%d)\n",
10873 utf16rev_textfilter, idx, maxlen, (int) count));
10877 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10878 Copy(SvPVX(sv), tmps, old, char);
10879 utf16_to_utf8((U8*)SvPVX(sv) + old, tmps + old,
10880 SvCUR(sv) - old, &newlen);
10881 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10883 DEBUG_P({ sv_dump(sv); });
10889 Returns a pointer to the next character after the parsed
10890 vstring, as well as updating the passed in sv.
10892 Function must be called like
10895 s = scan_vstring(s,sv);
10897 The sv should already be large enough to store the vstring
10898 passed in, for performance reasons.
10903 Perl_scan_vstring(pTHX_ char *s, SV *sv)
10907 if (*pos == 'v') pos++; /* get past 'v' */
10908 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
10910 if ( *pos != '.') {
10911 /* this may not be a v-string if followed by => */
10913 while (next < PL_bufend && isSPACE(*next))
10915 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
10916 /* return string not v-string */
10917 sv_setpvn(sv,(char *)s,pos-s);
10922 if (!isALPHA(*pos)) {
10924 U8 tmpbuf[UTF8_MAXBYTES+1];
10927 if (*s == 'v') s++; /* get past 'v' */
10929 sv_setpvn(sv, "", 0);
10934 /* this is atoi() that tolerates underscores */
10937 while (--end >= s) {
10942 rev += (*end - '0') * mult;
10944 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
10945 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10946 "Integer overflow in decimal number");
10950 if (rev > 0x7FFFFFFF)
10951 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
10953 /* Append native character for the rev point */
10954 tmpend = uvchr_to_utf8(tmpbuf, rev);
10955 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
10956 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
10958 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
10964 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
10968 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);