3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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 const char ident_too_long[] = "Identifier too long";
30 static const char commaless_variable_list[] = "comma-less variable list";
32 static void restore_rsfp(pTHX_ void *f);
33 #ifndef PERL_NO_UTF16_FILTER
34 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
35 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
39 /* XXX these probably need to be made into PL vars */
40 static I32 realtokenstart;
41 static I32 faketokens = 0;
42 static MADPROP *thismad;
51 static I32 curforce = -1;
53 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
55 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
57 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
60 #define XFAKEBRACK 128
63 #ifdef USE_UTF8_SCRIPTS
64 # define UTF (!IN_BYTES)
66 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
69 /* In variables named $^X, these are the legal values for X.
70 * 1999-02-27 mjd-perl-patch@plover.com */
71 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
73 /* On MacOS, respect nonbreaking spaces */
74 #ifdef MACOS_TRADITIONAL
75 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
77 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
80 /* LEX_* are values for PL_lex_state, the state of the lexer.
81 * They are arranged oddly so that the guard on the switch statement
82 * can get by with a single comparison (if the compiler is smart enough).
85 /* #define LEX_NOTPARSING 11 is done in perl.h. */
87 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
88 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
89 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
90 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
91 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
93 /* at end of code, eg "$x" followed by: */
94 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
95 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
97 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
98 string or after \E, $foo, etc */
99 #define LEX_INTERPCONST 2 /* NOT USED */
100 #define LEX_FORMLINE 1 /* expecting a format line */
101 #define LEX_KNOWNEXT 0 /* next token known; just return it */
105 static const char* const lex_state_names[] = {
124 #include "keywords.h"
126 /* CLINE is a macro that ensures PL_copline has a sane value */
131 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
133 #if 0 && defined(PERL_MAD)
134 # define SKIPSPACE0(s) skipspace0(s)
135 # define SKIPSPACE1(s) skipspace1(s)
136 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
137 # define PEEKSPACE(s) skipspace2(s,0)
139 # define SKIPSPACE0(s) skipspace(s)
140 # define SKIPSPACE1(s) skipspace(s)
141 # define SKIPSPACE2(s,tsv) skipspace(s)
142 # define PEEKSPACE(s) skipspace(s)
146 * Convenience functions to return different tokens and prime the
147 * lexer for the next token. They all take an argument.
149 * TOKEN : generic token (used for '(', DOLSHARP, etc)
150 * OPERATOR : generic operator
151 * AOPERATOR : assignment operator
152 * PREBLOCK : beginning the block after an if, while, foreach, ...
153 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
154 * PREREF : *EXPR where EXPR is not a simple identifier
155 * TERM : expression term
156 * LOOPX : loop exiting command (goto, last, dump, etc)
157 * FTST : file test operator
158 * FUN0 : zero-argument function
159 * FUN1 : not used, except for not, which isn't a UNIOP
160 * BOop : bitwise or or xor
162 * SHop : shift operator
163 * PWop : power operator
164 * PMop : pattern-matching operator
165 * Aop : addition-level operator
166 * Mop : multiplication-level operator
167 * Eop : equality-testing operator
168 * Rop : relational operator <= != gt
170 * Also see LOP and lop() below.
173 #ifdef DEBUGGING /* Serve -DT. */
174 # define REPORT(retval) tokereport((I32)retval)
176 # define REPORT(retval) (retval)
179 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
180 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
181 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
182 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
183 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
184 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
185 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
186 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
187 #define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
188 #define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
189 #define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
190 #define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
191 #define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
192 #define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
193 #define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
194 #define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
195 #define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
196 #define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
197 #define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
198 #define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
200 /* This bit of chicanery makes a unary function followed by
201 * a parenthesis into a function with one argument, highest precedence.
202 * The UNIDOR macro is for unary functions that can be followed by the //
203 * operator (such as C<shift // 0>).
205 #define UNI2(f,x) { \
209 PL_last_uni = PL_oldbufptr; \
210 PL_last_lop_op = f; \
212 return REPORT( (int)FUNC1 ); \
214 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
216 #define UNI(f) UNI2(f,XTERM)
217 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
219 #define UNIBRACK(f) { \
222 PL_last_uni = PL_oldbufptr; \
224 return REPORT( (int)FUNC1 ); \
226 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
229 /* grandfather return to old style */
230 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
234 /* how to interpret the yylval associated with the token */
238 TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
244 static struct debug_tokens {
246 enum token_type type;
248 } const debug_tokens[] =
250 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
251 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
252 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
253 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
254 { ARROW, TOKENTYPE_NONE, "ARROW" },
255 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
256 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
257 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
258 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
259 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
260 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
261 { DO, TOKENTYPE_NONE, "DO" },
262 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
263 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
264 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
265 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
266 { ELSE, TOKENTYPE_NONE, "ELSE" },
267 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
268 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
269 { FOR, TOKENTYPE_IVAL, "FOR" },
270 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
271 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
272 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
273 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
274 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
275 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
276 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
277 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
278 { IF, TOKENTYPE_IVAL, "IF" },
279 { LABEL, TOKENTYPE_PVAL, "LABEL" },
280 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
281 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
282 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
283 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
284 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
285 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
286 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
287 { MY, TOKENTYPE_IVAL, "MY" },
288 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
289 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
290 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
291 { OROP, TOKENTYPE_IVAL, "OROP" },
292 { OROR, TOKENTYPE_NONE, "OROR" },
293 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
294 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
295 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
296 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
297 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
298 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
299 { PREINC, TOKENTYPE_NONE, "PREINC" },
300 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
301 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
302 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
303 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
304 { SUB, TOKENTYPE_NONE, "SUB" },
305 { THING, TOKENTYPE_OPVAL, "THING" },
306 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
307 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
308 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
309 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
310 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
311 { USE, TOKENTYPE_IVAL, "USE" },
312 { WHEN, TOKENTYPE_IVAL, "WHEN" },
313 { WHILE, TOKENTYPE_IVAL, "WHILE" },
314 { WORD, TOKENTYPE_OPVAL, "WORD" },
315 { 0, TOKENTYPE_NONE, 0 }
318 /* dump the returned token in rv, plus any optional arg in yylval */
321 S_tokereport(pTHX_ I32 rv)
325 const char *name = NULL;
326 enum token_type type = TOKENTYPE_NONE;
327 const struct debug_tokens *p;
328 SV* const report = newSVpvs("<== ");
330 for (p = debug_tokens; p->token; p++) {
331 if (p->token == (int)rv) {
338 Perl_sv_catpv(aTHX_ report, name);
339 else if ((char)rv > ' ' && (char)rv < '~')
340 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
342 sv_catpvs(report, "EOF");
344 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
347 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
350 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
352 case TOKENTYPE_OPNUM:
353 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
354 PL_op_name[yylval.ival]);
357 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
359 case TOKENTYPE_OPVAL:
361 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
362 PL_op_name[yylval.opval->op_type]);
363 if (yylval.opval->op_type == OP_CONST) {
364 Perl_sv_catpvf(aTHX_ report, " %s",
365 SvPEEK(cSVOPx_sv(yylval.opval)));
370 sv_catpvs(report, "(opval=null)");
373 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
379 /* print the buffer with suitable escapes */
382 S_printbuf(pTHX_ const char* fmt, const char* s)
384 SV* const tmp = newSVpvs("");
385 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
394 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
395 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
399 S_ao(pTHX_ int toketype)
402 if (*PL_bufptr == '=') {
404 if (toketype == ANDAND)
405 yylval.ival = OP_ANDASSIGN;
406 else if (toketype == OROR)
407 yylval.ival = OP_ORASSIGN;
408 else if (toketype == DORDOR)
409 yylval.ival = OP_DORASSIGN;
417 * When Perl expects an operator and finds something else, no_op
418 * prints the warning. It always prints "<something> found where
419 * operator expected. It prints "Missing semicolon on previous line?"
420 * if the surprise occurs at the start of the line. "do you need to
421 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
422 * where the compiler doesn't know if foo is a method call or a function.
423 * It prints "Missing operator before end of line" if there's nothing
424 * after the missing operator, or "... before <...>" if there is something
425 * after the missing operator.
429 S_no_op(pTHX_ const char *what, char *s)
432 char * const oldbp = PL_bufptr;
433 const bool is_first = (PL_oldbufptr == PL_linestart);
439 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
440 if (ckWARN_d(WARN_SYNTAX)) {
442 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
443 "\t(Missing semicolon on previous line?)\n");
444 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
446 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
447 if (t < PL_bufptr && isSPACE(*t))
448 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
449 "\t(Do you need to predeclare %.*s?)\n",
450 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
454 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
455 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
463 * Complain about missing quote/regexp/heredoc terminator.
464 * If it's called with (char *)NULL then it cauterizes the line buffer.
465 * If we're in a delimited string and the delimiter is a control
466 * character, it's reformatted into a two-char sequence like ^C.
471 S_missingterm(pTHX_ char *s)
477 char * const nl = strrchr(s,'\n');
483 iscntrl(PL_multi_close)
485 PL_multi_close < 32 || PL_multi_close == 127
489 tmpbuf[1] = (char)toCTRL(PL_multi_close);
494 *tmpbuf = (char)PL_multi_close;
498 q = strchr(s,'"') ? '\'' : '"';
499 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
502 #define FEATURE_IS_ENABLED(name) \
503 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
504 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
506 * S_feature_is_enabled
507 * Check whether the named feature is enabled.
510 S_feature_is_enabled(pTHX_ char *name, STRLEN namelen)
513 HV * const hinthv = GvHV(PL_hintgv);
514 char he_name[32] = "feature_";
515 (void) strncpy(&he_name[8], name, 24);
517 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
525 Perl_deprecate(pTHX_ const char *s)
527 if (ckWARN(WARN_DEPRECATED))
528 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
532 Perl_deprecate_old(pTHX_ const char *s)
534 /* This function should NOT be called for any new deprecated warnings */
535 /* Use Perl_deprecate instead */
537 /* It is here to maintain backward compatibility with the pre-5.8 */
538 /* warnings category hierarchy. The "deprecated" category used to */
539 /* live under the "syntax" category. It is now a top-level category */
540 /* in its own right. */
542 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
543 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
544 "Use of %s is deprecated", s);
548 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
549 * utf16-to-utf8-reversed.
552 #ifdef PERL_CR_FILTER
556 register const char *s = SvPVX_const(sv);
557 register const char * const e = s + SvCUR(sv);
558 /* outer loop optimized to do nothing if there are no CR-LFs */
560 if (*s++ == '\r' && *s == '\n') {
561 /* hit a CR-LF, need to copy the rest */
562 register char *d = s - 1;
565 if (*s == '\r' && s[1] == '\n')
576 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
578 const I32 count = FILTER_READ(idx+1, sv, maxlen);
579 if (count > 0 && !maxlen)
587 * Initialize variables. Uses the Perl save_stack to save its state (for
588 * recursive calls to the parser).
592 Perl_lex_start(pTHX_ SV *line)
598 SAVEI32(PL_lex_dojoin);
599 SAVEI32(PL_lex_brackets);
600 SAVEI32(PL_lex_casemods);
601 SAVEI32(PL_lex_starts);
602 SAVEI32(PL_lex_state);
603 SAVEVPTR(PL_lex_inpat);
604 SAVEI32(PL_lex_inwhat);
605 if (PL_lex_state == LEX_KNOWNEXT) {
606 I32 toke = PL_nexttoke;
607 while (--toke >= 0) {
608 SAVEI32(PL_nexttype[toke]);
609 SAVEVPTR(PL_nextval[toke]);
611 SAVEI32(PL_nexttoke);
613 SAVECOPLINE(PL_curcop);
616 SAVEPPTR(PL_oldbufptr);
617 SAVEPPTR(PL_oldoldbufptr);
618 SAVEPPTR(PL_last_lop);
619 SAVEPPTR(PL_last_uni);
620 SAVEPPTR(PL_linestart);
621 SAVESPTR(PL_linestr);
622 SAVEGENERICPV(PL_lex_brackstack);
623 SAVEGENERICPV(PL_lex_casestack);
624 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
625 SAVESPTR(PL_lex_stuff);
626 SAVEI32(PL_lex_defer);
627 SAVEI32(PL_sublex_info.sub_inwhat);
628 SAVESPTR(PL_lex_repl);
630 SAVEINT(PL_lex_expect);
632 PL_lex_state = LEX_NORMAL;
636 Newx(PL_lex_brackstack, 120, char);
637 Newx(PL_lex_casestack, 12, char);
639 *PL_lex_casestack = '\0';
647 PL_sublex_info.sub_inwhat = 0;
649 if (SvREADONLY(PL_linestr))
650 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
651 s = SvPV_const(PL_linestr, len);
652 if (!len || s[len-1] != ';') {
653 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
654 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
655 sv_catpvs(PL_linestr, "\n;");
657 SvTEMP_off(PL_linestr);
658 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
659 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
660 PL_last_lop = PL_last_uni = NULL;
666 * Finalizer for lexing operations. Must be called when the parser is
667 * done with the lexer.
674 PL_doextract = FALSE;
679 * This subroutine has nothing to do with tilting, whether at windmills
680 * or pinball tables. Its name is short for "increment line". It
681 * increments the current line number in CopLINE(PL_curcop) and checks
682 * to see whether the line starts with a comment of the form
683 * # line 500 "foo.pm"
684 * If so, it sets the current line number and file to the values in the comment.
688 S_incline(pTHX_ char *s)
696 CopLINE_inc(PL_curcop);
699 while (SPACE_OR_TAB(*s)) s++;
700 if (strnEQ(s, "line", 4))
704 if (SPACE_OR_TAB(*s))
708 while (SPACE_OR_TAB(*s)) s++;
714 while (SPACE_OR_TAB(*s))
716 if (*s == '"' && (t = strchr(s+1, '"'))) {
721 for (t = s; !isSPACE(*t); t++) ;
724 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
726 if (*e != '\n' && *e != '\0')
727 return; /* false alarm */
733 const char * const cf = CopFILE(PL_curcop);
734 STRLEN tmplen = cf ? strlen(cf) : 0;
735 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
736 /* must copy *{"::_<(eval N)[oldfilename:L]"}
737 * to *{"::_<newfilename"} */
738 char smallbuf[256], smallbuf2[256];
739 char *tmpbuf, *tmpbuf2;
741 STRLEN tmplen2 = strlen(s);
742 if (tmplen + 3 < sizeof smallbuf)
745 Newx(tmpbuf, tmplen + 3, char);
746 if (tmplen2 + 3 < sizeof smallbuf2)
749 Newx(tmpbuf2, tmplen2 + 3, char);
750 tmpbuf[0] = tmpbuf2[0] = '_';
751 tmpbuf[1] = tmpbuf2[1] = '<';
752 memcpy(tmpbuf + 2, cf, ++tmplen);
753 memcpy(tmpbuf2 + 2, s, ++tmplen2);
755 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
757 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
759 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
760 /* adjust ${"::_<newfilename"} to store the new file name */
761 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
762 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
763 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
765 if (tmpbuf != smallbuf) Safefree(tmpbuf);
766 if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
769 CopFILE_free(PL_curcop);
770 CopFILE_set(PL_curcop, s);
773 CopLINE_set(PL_curcop, atoi(n)-1);
777 /* skip space before thistoken */
780 S_skipspace0(pTHX_ register char *s)
787 thiswhite = newSVpvn("",0);
788 sv_catsv(thiswhite, skipwhite);
792 realtokenstart = s - SvPVX(PL_linestr);
796 /* skip space after thistoken */
799 S_skipspace1(pTHX_ register char *s)
802 I32 startoff = start - SvPVX(PL_linestr);
807 start = SvPVX(PL_linestr) + startoff;
808 if (!thistoken && realtokenstart >= 0) {
809 char *tstart = SvPVX(PL_linestr) + realtokenstart;
810 thistoken = newSVpvn(tstart, start - tstart);
815 nextwhite = newSVpvn("",0);
816 sv_catsv(nextwhite, skipwhite);
824 S_skipspace2(pTHX_ register char *s, SV **svp)
827 I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
828 I32 startoff = start - SvPVX(PL_linestr);
830 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
831 if (!PL_madskills || !svp)
833 start = SvPVX(PL_linestr) + startoff;
834 if (!thistoken && realtokenstart >= 0) {
835 char *tstart = SvPVX(PL_linestr) + realtokenstart;
836 thistoken = newSVpvn(tstart, start - tstart);
841 *svp = newSVpvn("",0);
842 sv_setsv(*svp, skipwhite);
853 * Called to gobble the appropriate amount and type of whitespace.
854 * Skips comments as well.
858 S_skipspace(pTHX_ register char *s)
861 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
862 while (s < PL_bufend && SPACE_OR_TAB(*s))
868 SSize_t oldprevlen, oldoldprevlen;
869 SSize_t oldloplen = 0, oldunilen = 0;
870 while (s < PL_bufend && isSPACE(*s)) {
871 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
876 if (s < PL_bufend && *s == '#') {
877 while (s < PL_bufend && *s != '\n')
881 if (PL_in_eval && !PL_rsfp) {
888 /* only continue to recharge the buffer if we're at the end
889 * of the buffer, we're not reading from a source filter, and
890 * we're in normal lexing mode
892 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
893 PL_lex_state == LEX_FORMLINE)
896 /* try to recharge the buffer */
897 if ((s = filter_gets(PL_linestr, PL_rsfp,
898 (prevlen = SvCUR(PL_linestr)))) == NULL)
900 /* end of file. Add on the -p or -n magic */
903 ";}continue{print or die qq(-p destination: $!\\n);}");
904 PL_minus_n = PL_minus_p = 0;
906 else if (PL_minus_n) {
907 sv_setpvn(PL_linestr, ";}", 2);
911 sv_setpvn(PL_linestr,";", 1);
913 /* reset variables for next time we lex */
914 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
916 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
917 PL_last_lop = PL_last_uni = NULL;
919 /* Close the filehandle. Could be from -P preprocessor,
920 * STDIN, or a regular file. If we were reading code from
921 * STDIN (because the commandline held no -e or filename)
922 * then we don't close it, we reset it so the code can
923 * read from STDIN too.
926 if (PL_preprocess && !PL_in_eval)
927 (void)PerlProc_pclose(PL_rsfp);
928 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
929 PerlIO_clearerr(PL_rsfp);
931 (void)PerlIO_close(PL_rsfp);
936 /* not at end of file, so we only read another line */
937 /* make corresponding updates to old pointers, for yyerror() */
938 oldprevlen = PL_oldbufptr - PL_bufend;
939 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
941 oldunilen = PL_last_uni - PL_bufend;
943 oldloplen = PL_last_lop - PL_bufend;
944 PL_linestart = PL_bufptr = s + prevlen;
945 PL_bufend = s + SvCUR(PL_linestr);
947 PL_oldbufptr = s + oldprevlen;
948 PL_oldoldbufptr = s + oldoldprevlen;
950 PL_last_uni = s + oldunilen;
952 PL_last_lop = s + oldloplen;
955 /* debugger active and we're not compiling the debugger code,
956 * so store the line into the debugger's array of lines
958 if (PERLDB_LINE && PL_curstash != PL_debstash) {
959 SV * const sv = newSV(0);
961 sv_upgrade(sv, SVt_PVMG);
962 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
965 av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
972 * Check the unary operators to ensure there's no ambiguity in how they're
973 * used. An ambiguous piece of code would be:
975 * This doesn't mean rand() + 5. Because rand() is a unary operator,
976 * the +5 is its argument.
986 if (PL_oldoldbufptr != PL_last_uni)
988 while (isSPACE(*PL_last_uni))
990 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
991 if ((t = strchr(s, '(')) && t < PL_bufptr)
994 /* XXX Things like this are just so nasty. We shouldn't be modifying
995 source code, even if we realquick set it back. */
996 if (ckWARN_d(WARN_AMBIGUOUS)){
999 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1000 "Warning: Use of \"%s\" without parentheses is ambiguous",
1007 * LOP : macro to build a list operator. Its behaviour has been replaced
1008 * with a subroutine, S_lop() for which LOP is just another name.
1011 #define LOP(f,x) return lop(f,x,s)
1015 * Build a list operator (or something that might be one). The rules:
1016 * - if we have a next token, then it's a list operator [why?]
1017 * - if the next thing is an opening paren, then it's a function
1018 * - else it's a list operator
1022 S_lop(pTHX_ I32 f, int x, char *s)
1029 PL_last_lop = PL_oldbufptr;
1030 PL_last_lop_op = (OPCODE)f;
1032 return REPORT(LSTOP);
1034 return REPORT(FUNC);
1037 return REPORT(FUNC);
1039 return REPORT(LSTOP);
1044 * When the lexer realizes it knows the next token (for instance,
1045 * it is reordering tokens for the parser) then it can call S_force_next
1046 * to know what token to return the next time the lexer is called. Caller
1047 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
1048 * handles the token correctly.
1052 S_force_next(pTHX_ I32 type)
1055 PL_nexttype[PL_nexttoke] = type;
1057 if (PL_lex_state != LEX_KNOWNEXT) {
1058 PL_lex_defer = PL_lex_state;
1059 PL_lex_expect = PL_expect;
1060 PL_lex_state = LEX_KNOWNEXT;
1065 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
1068 SV * const sv = newSVpvn(start,len);
1069 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
1076 * When the lexer knows the next thing is a word (for instance, it has
1077 * just seen -> and it knows that the next char is a word char, then
1078 * it calls S_force_word to stick the next word into the PL_next lookahead.
1081 * char *start : buffer position (must be within PL_linestr)
1082 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
1083 * int check_keyword : if true, Perl checks to make sure the word isn't
1084 * a keyword (do this if the word is a label, e.g. goto FOO)
1085 * int allow_pack : if true, : characters will also be allowed (require,
1086 * use, etc. do this)
1087 * int allow_initial_tick : used by the "sub" lexer only.
1091 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1097 start = SKIPSPACE1(start);
1099 if (isIDFIRST_lazy_if(s,UTF) ||
1100 (allow_pack && *s == ':') ||
1101 (allow_initial_tick && *s == '\'') )
1103 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1104 if (check_keyword && keyword(PL_tokenbuf, len))
1106 if (token == METHOD) {
1111 PL_expect = XOPERATOR;
1114 NEXTVAL_NEXTTOKE.opval
1115 = (OP*)newSVOP(OP_CONST,0,
1116 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1117 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1125 * Called when the lexer wants $foo *foo &foo etc, but the program
1126 * text only contains the "foo" portion. The first argument is a pointer
1127 * to the "foo", and the second argument is the type symbol to prefix.
1128 * Forces the next token to be a "WORD".
1129 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1133 S_force_ident(pTHX_ register const char *s, int kind)
1137 const STRLEN len = strlen(s);
1138 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1139 NEXTVAL_NEXTTOKE.opval = o;
1142 o->op_private = OPpCONST_ENTERED;
1143 /* XXX see note in pp_entereval() for why we forgo typo
1144 warnings if the symbol must be introduced in an eval.
1146 gv_fetchpvn_flags(s, len,
1147 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1149 kind == '$' ? SVt_PV :
1150 kind == '@' ? SVt_PVAV :
1151 kind == '%' ? SVt_PVHV :
1159 Perl_str_to_version(pTHX_ SV *sv)
1164 const char *start = SvPV_const(sv,len);
1165 const char * const end = start + len;
1166 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1167 while (start < end) {
1171 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1176 retval += ((NV)n)/nshift;
1185 * Forces the next token to be a version number.
1186 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1187 * and if "guessing" is TRUE, then no new token is created (and the caller
1188 * must use an alternative parsing method).
1192 S_force_version(pTHX_ char *s, int guessing)
1204 while (isDIGIT(*d) || *d == '_' || *d == '.')
1206 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1208 s = scan_num(s, &yylval);
1209 version = yylval.opval;
1210 ver = cSVOPx(version)->op_sv;
1211 if (SvPOK(ver) && !SvNIOK(ver)) {
1212 SvUPGRADE(ver, SVt_PVNV);
1213 SvNV_set(ver, str_to_version(ver));
1214 SvNOK_on(ver); /* hint that it is a version */
1221 /* NOTE: The parser sees the package name and the VERSION swapped */
1222 NEXTVAL_NEXTTOKE.opval = version;
1230 * Tokenize a quoted string passed in as an SV. It finds the next
1231 * chunk, up to end of string or a backslash. It may make a new
1232 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1237 S_tokeq(pTHX_ SV *sv)
1241 register char *send;
1249 s = SvPV_force(sv, len);
1250 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1253 while (s < send && *s != '\\')
1258 if ( PL_hints & HINT_NEW_STRING ) {
1259 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1265 if (s + 1 < send && (s[1] == '\\'))
1266 s++; /* all that, just for this */
1271 SvCUR_set(sv, d - SvPVX_const(sv));
1273 if ( PL_hints & HINT_NEW_STRING )
1274 return new_constant(NULL, 0, "q", sv, pv, "q");
1279 * Now come three functions related to double-quote context,
1280 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1281 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1282 * interact with PL_lex_state, and create fake ( ... ) argument lists
1283 * to handle functions and concatenation.
1284 * They assume that whoever calls them will be setting up a fake
1285 * join call, because each subthing puts a ',' after it. This lets
1288 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1290 * (I'm not sure whether the spurious commas at the end of lcfirst's
1291 * arguments and join's arguments are created or not).
1296 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1298 * Pattern matching will set PL_lex_op to the pattern-matching op to
1299 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1301 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1303 * Everything else becomes a FUNC.
1305 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1306 * had an OP_CONST or OP_READLINE). This just sets us up for a
1307 * call to S_sublex_push().
1311 S_sublex_start(pTHX)
1314 register const I32 op_type = yylval.ival;
1316 if (op_type == OP_NULL) {
1317 yylval.opval = PL_lex_op;
1321 if (op_type == OP_CONST || op_type == OP_READLINE) {
1322 SV *sv = tokeq(PL_lex_stuff);
1324 if (SvTYPE(sv) == SVt_PVIV) {
1325 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1327 const char * const p = SvPV_const(sv, len);
1328 SV * const nsv = newSVpvn(p, len);
1334 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1335 PL_lex_stuff = NULL;
1336 /* Allow <FH> // "foo" */
1337 if (op_type == OP_READLINE)
1338 PL_expect = XTERMORDORDOR;
1342 PL_sublex_info.super_state = PL_lex_state;
1343 PL_sublex_info.sub_inwhat = op_type;
1344 PL_sublex_info.sub_op = PL_lex_op;
1345 PL_lex_state = LEX_INTERPPUSH;
1349 yylval.opval = PL_lex_op;
1359 * Create a new scope to save the lexing state. The scope will be
1360 * ended in S_sublex_done. Returns a '(', starting the function arguments
1361 * to the uc, lc, etc. found before.
1362 * Sets PL_lex_state to LEX_INTERPCONCAT.
1371 PL_lex_state = PL_sublex_info.super_state;
1372 SAVEI32(PL_lex_dojoin);
1373 SAVEI32(PL_lex_brackets);
1374 SAVEI32(PL_lex_casemods);
1375 SAVEI32(PL_lex_starts);
1376 SAVEI32(PL_lex_state);
1377 SAVEVPTR(PL_lex_inpat);
1378 SAVEI32(PL_lex_inwhat);
1379 SAVECOPLINE(PL_curcop);
1380 SAVEPPTR(PL_bufptr);
1381 SAVEPPTR(PL_bufend);
1382 SAVEPPTR(PL_oldbufptr);
1383 SAVEPPTR(PL_oldoldbufptr);
1384 SAVEPPTR(PL_last_lop);
1385 SAVEPPTR(PL_last_uni);
1386 SAVEPPTR(PL_linestart);
1387 SAVESPTR(PL_linestr);
1388 SAVEGENERICPV(PL_lex_brackstack);
1389 SAVEGENERICPV(PL_lex_casestack);
1391 PL_linestr = PL_lex_stuff;
1392 PL_lex_stuff = NULL;
1394 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1395 = SvPVX(PL_linestr);
1396 PL_bufend += SvCUR(PL_linestr);
1397 PL_last_lop = PL_last_uni = NULL;
1398 SAVEFREESV(PL_linestr);
1400 PL_lex_dojoin = FALSE;
1401 PL_lex_brackets = 0;
1402 Newx(PL_lex_brackstack, 120, char);
1403 Newx(PL_lex_casestack, 12, char);
1404 PL_lex_casemods = 0;
1405 *PL_lex_casestack = '\0';
1407 PL_lex_state = LEX_INTERPCONCAT;
1408 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1410 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1411 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1412 PL_lex_inpat = PL_sublex_info.sub_op;
1414 PL_lex_inpat = NULL;
1421 * Restores lexer state after a S_sublex_push.
1428 if (!PL_lex_starts++) {
1429 SV * const sv = newSVpvs("");
1430 if (SvUTF8(PL_linestr))
1432 PL_expect = XOPERATOR;
1433 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1437 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1438 PL_lex_state = LEX_INTERPCASEMOD;
1442 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1443 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1444 PL_linestr = PL_lex_repl;
1446 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1447 PL_bufend += SvCUR(PL_linestr);
1448 PL_last_lop = PL_last_uni = NULL;
1449 SAVEFREESV(PL_linestr);
1450 PL_lex_dojoin = FALSE;
1451 PL_lex_brackets = 0;
1452 PL_lex_casemods = 0;
1453 *PL_lex_casestack = '\0';
1455 if (SvEVALED(PL_lex_repl)) {
1456 PL_lex_state = LEX_INTERPNORMAL;
1458 /* we don't clear PL_lex_repl here, so that we can check later
1459 whether this is an evalled subst; that means we rely on the
1460 logic to ensure sublex_done() is called again only via the
1461 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1464 PL_lex_state = LEX_INTERPCONCAT;
1471 PL_bufend = SvPVX(PL_linestr);
1472 PL_bufend += SvCUR(PL_linestr);
1473 PL_expect = XOPERATOR;
1474 PL_sublex_info.sub_inwhat = 0;
1482 Extracts a pattern, double-quoted string, or transliteration. This
1485 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1486 processing a pattern (PL_lex_inpat is true), a transliteration
1487 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1489 Returns a pointer to the character scanned up to. Iff this is
1490 advanced from the start pointer supplied (ie if anything was
1491 successfully parsed), will leave an OP for the substring scanned
1492 in yylval. Caller must intuit reason for not parsing further
1493 by looking at the next characters herself.
1497 double-quoted style: \r and \n
1498 regexp special ones: \D \s
1500 backrefs: \1 (deprecated in substitution replacements)
1501 case and quoting: \U \Q \E
1502 stops on @ and $, but not for $ as tail anchor
1504 In transliterations:
1505 characters are VERY literal, except for - not at the start or end
1506 of the string, which indicates a range. scan_const expands the
1507 range to the full set of intermediate characters.
1509 In double-quoted strings:
1511 double-quoted style: \r and \n
1513 backrefs: \1 (deprecated)
1514 case and quoting: \U \Q \E
1517 scan_const does *not* construct ops to handle interpolated strings.
1518 It stops processing as soon as it finds an embedded $ or @ variable
1519 and leaves it to the caller to work out what's going on.
1521 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1523 $ in pattern could be $foo or could be tail anchor. Assumption:
1524 it's a tail anchor if $ is the last thing in the string, or if it's
1525 followed by one of ")| \n\t"
1527 \1 (backreferences) are turned into $1
1529 The structure of the code is
1530 while (there's a character to process) {
1531 handle transliteration ranges
1532 skip regexp comments
1533 skip # initiated comments in //x patterns
1534 check for embedded @foo
1535 check for embedded scalars
1537 leave intact backslashes from leave (below)
1538 deprecate \1 in strings and sub replacements
1539 handle string-changing backslashes \l \U \Q \E, etc.
1540 switch (what was escaped) {
1541 handle - in a transliteration (becomes a literal -)
1542 handle \132 octal characters
1543 handle 0x15 hex characters
1544 handle \cV (control V)
1545 handle printf backslashes (\f, \r, \n, etc)
1547 } (end if backslash)
1548 } (end while character to read)
1553 S_scan_const(pTHX_ char *start)
1556 register char *send = PL_bufend; /* end of the constant */
1557 SV *sv = newSV(send - start); /* sv for the constant */
1558 register char *s = start; /* start of the constant */
1559 register char *d = SvPVX(sv); /* destination for copies */
1560 bool dorange = FALSE; /* are we in a translit range? */
1561 bool didrange = FALSE; /* did we just finish a range? */
1562 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1563 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1566 UV literal_endpoint = 0;
1569 const char *leaveit = /* set of acceptably-backslashed characters */
1571 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1574 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1575 /* If we are doing a trans and we know we want UTF8 set expectation */
1576 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1577 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1581 while (s < send || dorange) {
1582 /* get transliterations out of the way (they're most literal) */
1583 if (PL_lex_inwhat == OP_TRANS) {
1584 /* expand a range A-Z to the full set of characters. AIE! */
1586 I32 i; /* current expanded character */
1587 I32 min; /* first character in range */
1588 I32 max; /* last character in range */
1591 char * const c = (char*)utf8_hop((U8*)d, -1);
1595 *c = (char)UTF_TO_NATIVE(0xff);
1596 /* mark the range as done, and continue */
1602 i = d - SvPVX_const(sv); /* remember current offset */
1603 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1604 d = SvPVX(sv) + i; /* refresh d after realloc */
1605 d -= 2; /* eat the first char and the - */
1607 min = (U8)*d; /* first char in range */
1608 max = (U8)d[1]; /* last char in range */
1612 "Invalid range \"%c-%c\" in transliteration operator",
1613 (char)min, (char)max);
1617 if (literal_endpoint == 2 &&
1618 ((isLOWER(min) && isLOWER(max)) ||
1619 (isUPPER(min) && isUPPER(max)))) {
1621 for (i = min; i <= max; i++)
1623 *d++ = NATIVE_TO_NEED(has_utf8,i);
1625 for (i = min; i <= max; i++)
1627 *d++ = NATIVE_TO_NEED(has_utf8,i);
1632 for (i = min; i <= max; i++)
1635 /* mark the range as done, and continue */
1639 literal_endpoint = 0;
1644 /* range begins (ignore - as first or last char) */
1645 else if (*s == '-' && s+1 < send && s != start) {
1647 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1650 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1660 literal_endpoint = 0;
1665 /* if we get here, we're not doing a transliteration */
1667 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1668 except for the last char, which will be done separately. */
1669 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1671 while (s+1 < send && *s != ')')
1672 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1674 else if (s[2] == '{' /* This should match regcomp.c */
1675 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1678 char *regparse = s + (s[2] == '{' ? 3 : 4);
1681 while (count && (c = *regparse)) {
1682 if (c == '\\' && regparse[1])
1690 if (*regparse != ')')
1691 regparse--; /* Leave one char for continuation. */
1692 while (s < regparse)
1693 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1697 /* likewise skip #-initiated comments in //x patterns */
1698 else if (*s == '#' && PL_lex_inpat &&
1699 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1700 while (s+1 < send && *s != '\n')
1701 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1704 /* check for embedded arrays
1705 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1707 else if (*s == '@' && s[1]
1708 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1711 /* check for embedded scalars. only stop if we're sure it's a
1714 else if (*s == '$') {
1715 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1717 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1718 break; /* in regexp, $ might be tail anchor */
1721 /* End of else if chain - OP_TRANS rejoin rest */
1724 if (*s == '\\' && s+1 < send) {
1727 /* some backslashes we leave behind */
1728 if (*leaveit && *s && strchr(leaveit, *s)) {
1729 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1730 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1734 /* deprecate \1 in strings and substitution replacements */
1735 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1736 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1738 if (ckWARN(WARN_SYNTAX))
1739 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1744 /* string-change backslash escapes */
1745 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1750 /* if we get here, it's either a quoted -, or a digit */
1753 /* quoted - in transliterations */
1755 if (PL_lex_inwhat == OP_TRANS) {
1765 Perl_warner(aTHX_ packWARN(WARN_MISC),
1766 "Unrecognized escape \\%c passed through",
1768 /* default action is to copy the quoted character */
1769 goto default_action;
1772 /* \132 indicates an octal constant */
1773 case '0': case '1': case '2': case '3':
1774 case '4': case '5': case '6': case '7':
1778 uv = grok_oct(s, &len, &flags, NULL);
1781 goto NUM_ESCAPE_INSERT;
1783 /* \x24 indicates a hex constant */
1787 char* const e = strchr(s, '}');
1788 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1789 PERL_SCAN_DISALLOW_PREFIX;
1794 yyerror("Missing right brace on \\x{}");
1798 uv = grok_hex(s, &len, &flags, NULL);
1804 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1805 uv = grok_hex(s, &len, &flags, NULL);
1811 /* Insert oct or hex escaped character.
1812 * There will always enough room in sv since such
1813 * escapes will be longer than any UTF-8 sequence
1814 * they can end up as. */
1816 /* We need to map to chars to ASCII before doing the tests
1819 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1820 if (!has_utf8 && uv > 255) {
1821 /* Might need to recode whatever we have
1822 * accumulated so far if it contains any
1825 * (Can't we keep track of that and avoid
1826 * this rescan? --jhi)
1830 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1831 if (!NATIVE_IS_INVARIANT(*c)) {
1836 const STRLEN offset = d - SvPVX_const(sv);
1838 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1842 while (src >= (const U8 *)SvPVX_const(sv)) {
1843 if (!NATIVE_IS_INVARIANT(*src)) {
1844 const U8 ch = NATIVE_TO_ASCII(*src);
1845 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1846 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1856 if (has_utf8 || uv > 255) {
1857 d = (char*)uvchr_to_utf8((U8*)d, uv);
1859 if (PL_lex_inwhat == OP_TRANS &&
1860 PL_sublex_info.sub_op) {
1861 PL_sublex_info.sub_op->op_private |=
1862 (PL_lex_repl ? OPpTRANS_FROM_UTF
1875 /* \N{LATIN SMALL LETTER A} is a named character */
1879 char* e = strchr(s, '}');
1885 yyerror("Missing right brace on \\N{}");
1889 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1891 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1892 PERL_SCAN_DISALLOW_PREFIX;
1895 uv = grok_hex(s, &len, &flags, NULL);
1897 goto NUM_ESCAPE_INSERT;
1899 res = newSVpvn(s + 1, e - s - 1);
1900 res = new_constant( NULL, 0, "charnames",
1901 res, NULL, "\\N{...}" );
1903 sv_utf8_upgrade(res);
1904 str = SvPV_const(res,len);
1905 #ifdef EBCDIC_NEVER_MIND
1906 /* charnames uses pack U and that has been
1907 * recently changed to do the below uni->native
1908 * mapping, so this would be redundant (and wrong,
1909 * the code point would be doubly converted).
1910 * But leave this in just in case the pack U change
1911 * gets revoked, but the semantics is still
1912 * desireable for charnames. --jhi */
1914 UV uv = utf8_to_uvchr((const U8*)str, 0);
1917 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
1919 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1920 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1921 str = SvPV_const(res, len);
1925 if (!has_utf8 && SvUTF8(res)) {
1926 const char * const ostart = SvPVX_const(sv);
1927 SvCUR_set(sv, d - ostart);
1930 sv_utf8_upgrade(sv);
1931 /* this just broke our allocation above... */
1932 SvGROW(sv, (STRLEN)(send - start));
1933 d = SvPVX(sv) + SvCUR(sv);
1936 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1937 const char * const odest = SvPVX_const(sv);
1939 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1940 d = SvPVX(sv) + (d - odest);
1942 Copy(str, d, len, char);
1949 yyerror("Missing braces on \\N{}");
1952 /* \c is a control character */
1961 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1964 yyerror("Missing control char name in \\c");
1968 /* printf-style backslashes, formfeeds, newlines, etc */
1970 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1973 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1976 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1979 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1982 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1985 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1988 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1994 } /* end if (backslash) */
2001 /* If we started with encoded form, or already know we want it
2002 and then encode the next character */
2003 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2005 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2006 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2009 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2010 const STRLEN off = d - SvPVX_const(sv);
2011 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2013 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2017 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2019 } /* while loop to process each character */
2021 /* terminate the string and set up the sv */
2023 SvCUR_set(sv, d - SvPVX_const(sv));
2024 if (SvCUR(sv) >= SvLEN(sv))
2025 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2028 if (PL_encoding && !has_utf8) {
2029 sv_recode_to_utf8(sv, PL_encoding);
2035 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2036 PL_sublex_info.sub_op->op_private |=
2037 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2041 /* shrink the sv if we allocated more than we used */
2042 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2043 SvPV_shrink_to_cur(sv);
2046 /* return the substring (via yylval) only if we parsed anything */
2047 if (s > PL_bufptr) {
2048 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
2049 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
2051 ( PL_lex_inwhat == OP_TRANS
2053 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
2056 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2063 * Returns TRUE if there's more to the expression (e.g., a subscript),
2066 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2068 * ->[ and ->{ return TRUE
2069 * { and [ outside a pattern are always subscripts, so return TRUE
2070 * if we're outside a pattern and it's not { or [, then return FALSE
2071 * if we're in a pattern and the first char is a {
2072 * {4,5} (any digits around the comma) returns FALSE
2073 * if we're in a pattern and the first char is a [
2075 * [SOMETHING] has a funky algorithm to decide whether it's a
2076 * character class or not. It has to deal with things like
2077 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2078 * anything else returns TRUE
2081 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2084 S_intuit_more(pTHX_ register char *s)
2087 if (PL_lex_brackets)
2089 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2091 if (*s != '{' && *s != '[')
2096 /* In a pattern, so maybe we have {n,m}. */
2113 /* On the other hand, maybe we have a character class */
2116 if (*s == ']' || *s == '^')
2119 /* this is terrifying, and it works */
2120 int weight = 2; /* let's weigh the evidence */
2122 unsigned char un_char = 255, last_un_char;
2123 const char * const send = strchr(s,']');
2124 char tmpbuf[sizeof PL_tokenbuf * 4];
2126 if (!send) /* has to be an expression */
2129 Zero(seen,256,char);
2132 else if (isDIGIT(*s)) {
2134 if (isDIGIT(s[1]) && s[2] == ']')
2140 for (; s < send; s++) {
2141 last_un_char = un_char;
2142 un_char = (unsigned char)*s;
2147 weight -= seen[un_char] * 10;
2148 if (isALNUM_lazy_if(s+1,UTF)) {
2150 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2151 len = (int)strlen(tmpbuf);
2152 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2157 else if (*s == '$' && s[1] &&
2158 strchr("[#!%*<>()-=",s[1])) {
2159 if (/*{*/ strchr("])} =",s[2]))
2168 if (strchr("wds]",s[1]))
2170 else if (seen['\''] || seen['"'])
2172 else if (strchr("rnftbxcav",s[1]))
2174 else if (isDIGIT(s[1])) {
2176 while (s[1] && isDIGIT(s[1]))
2186 if (strchr("aA01! ",last_un_char))
2188 if (strchr("zZ79~",s[1]))
2190 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2191 weight -= 5; /* cope with negative subscript */
2194 if (!isALNUM(last_un_char)
2195 && !(last_un_char == '$' || last_un_char == '@'
2196 || last_un_char == '&')
2197 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2202 if (keyword(tmpbuf, d - tmpbuf))
2205 if (un_char == last_un_char + 1)
2207 weight -= seen[un_char];
2212 if (weight >= 0) /* probably a character class */
2222 * Does all the checking to disambiguate
2224 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2225 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2227 * First argument is the stuff after the first token, e.g. "bar".
2229 * Not a method if bar is a filehandle.
2230 * Not a method if foo is a subroutine prototyped to take a filehandle.
2231 * Not a method if it's really "Foo $bar"
2232 * Method if it's "foo $bar"
2233 * Not a method if it's really "print foo $bar"
2234 * Method if it's really "foo package::" (interpreted as package->foo)
2235 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2236 * Not a method if bar is a filehandle or package, but is quoted with
2241 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2244 char *s = start + (*start == '$');
2245 char tmpbuf[sizeof PL_tokenbuf];
2250 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2254 const char *proto = SvPVX_const(cv);
2265 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2266 /* start is the beginning of the possible filehandle/object,
2267 * and s is the end of it
2268 * tmpbuf is a copy of it
2271 if (*start == '$') {
2272 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2277 return *s == '(' ? FUNCMETH : METHOD;
2279 if (!keyword(tmpbuf, len)) {
2280 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2285 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2286 if (indirgv && GvCVu(indirgv))
2288 /* filehandle or package name makes it a method */
2289 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2291 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2292 return 0; /* no assumptions -- "=>" quotes bearword */
2294 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2295 newSVpvn(tmpbuf,len));
2296 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2300 return *s == '(' ? FUNCMETH : METHOD;
2308 * Return a string of Perl code to load the debugger. If PERL5DB
2309 * is set, it will return the contents of that, otherwise a
2310 * compile-time require of perl5db.pl.
2318 const char * const pdb = PerlEnv_getenv("PERL5DB");
2322 SETERRNO(0,SS_NORMAL);
2323 return "BEGIN { require 'perl5db.pl' }";
2329 /* Encoded script support. filter_add() effectively inserts a
2330 * 'pre-processing' function into the current source input stream.
2331 * Note that the filter function only applies to the current source file
2332 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2334 * The datasv parameter (which may be NULL) can be used to pass
2335 * private data to this instance of the filter. The filter function
2336 * can recover the SV using the FILTER_DATA macro and use it to
2337 * store private buffers and state information.
2339 * The supplied datasv parameter is upgraded to a PVIO type
2340 * and the IoDIRP/IoANY field is used to store the function pointer,
2341 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2342 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2343 * private use must be set using malloc'd pointers.
2347 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2353 if (!PL_rsfp_filters)
2354 PL_rsfp_filters = newAV();
2357 SvUPGRADE(datasv, SVt_PVIO);
2358 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2359 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2360 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2361 IoANY(datasv), SvPV_nolen(datasv)));
2362 av_unshift(PL_rsfp_filters, 1);
2363 av_store(PL_rsfp_filters, 0, datasv) ;
2368 /* Delete most recently added instance of this filter function. */
2370 Perl_filter_del(pTHX_ filter_t funcp)
2376 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
2378 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2380 /* if filter is on top of stack (usual case) just pop it off */
2381 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2382 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2383 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2384 IoANY(datasv) = (void *)NULL;
2385 sv_free(av_pop(PL_rsfp_filters));
2389 /* we need to search for the correct entry and clear it */
2390 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2394 /* Invoke the idxth filter function for the current rsfp. */
2395 /* maxlen 0 = read one text line */
2397 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2403 if (!PL_rsfp_filters)
2405 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2406 /* Provide a default input filter to make life easy. */
2407 /* Note that we append to the line. This is handy. */
2408 DEBUG_P(PerlIO_printf(Perl_debug_log,
2409 "filter_read %d: from rsfp\n", idx));
2413 const int old_len = SvCUR(buf_sv);
2415 /* ensure buf_sv is large enough */
2416 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2417 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2418 if (PerlIO_error(PL_rsfp))
2419 return -1; /* error */
2421 return 0 ; /* end of file */
2423 SvCUR_set(buf_sv, old_len + len) ;
2426 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2427 if (PerlIO_error(PL_rsfp))
2428 return -1; /* error */
2430 return 0 ; /* end of file */
2433 return SvCUR(buf_sv);
2435 /* Skip this filter slot if filter has been deleted */
2436 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2437 DEBUG_P(PerlIO_printf(Perl_debug_log,
2438 "filter_read %d: skipped (filter deleted)\n",
2440 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2442 /* Get function pointer hidden within datasv */
2443 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2444 DEBUG_P(PerlIO_printf(Perl_debug_log,
2445 "filter_read %d: via function %p (%s)\n",
2446 idx, datasv, SvPV_nolen_const(datasv)));
2447 /* Call function. The function is expected to */
2448 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2449 /* Return: <0:error, =0:eof, >0:not eof */
2450 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2454 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2457 #ifdef PERL_CR_FILTER
2458 if (!PL_rsfp_filters) {
2459 filter_add(S_cr_textfilter,NULL);
2462 if (PL_rsfp_filters) {
2464 SvCUR_set(sv, 0); /* start with empty line */
2465 if (FILTER_READ(0, sv, 0) > 0)
2466 return ( SvPVX(sv) ) ;
2471 return (sv_gets(sv, fp, append));
2475 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2480 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2484 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2485 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2487 return GvHV(gv); /* Foo:: */
2490 /* use constant CLASS => 'MyClass' */
2491 if ((gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV))) {
2493 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2494 pkgname = SvPV_nolen_const(sv);
2498 return gv_stashpv(pkgname, FALSE);
2502 S_tokenize_use(pTHX_ int is_use, char *s) {
2504 if (PL_expect != XSTATE)
2505 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
2506 is_use ? "use" : "no"));
2508 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
2509 s = force_version(s, TRUE);
2510 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
2511 NEXTVAL_NEXTTOKE.opval = NULL;
2514 else if (*s == 'v') {
2515 s = force_word(s,WORD,FALSE,TRUE,FALSE);
2516 s = force_version(s, FALSE);
2520 s = force_word(s,WORD,FALSE,TRUE,FALSE);
2521 s = force_version(s, FALSE);
2523 yylval.ival = is_use;
2527 static const char* const exp_name[] =
2528 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2529 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2536 Works out what to call the token just pulled out of the input
2537 stream. The yacc parser takes care of taking the ops we return and
2538 stitching them into a tree.
2544 if read an identifier
2545 if we're in a my declaration
2546 croak if they tried to say my($foo::bar)
2547 build the ops for a my() declaration
2548 if it's an access to a my() variable
2549 are we in a sort block?
2550 croak if my($a); $a <=> $b
2551 build ops for access to a my() variable
2552 if in a dq string, and they've said @foo and we can't find @foo
2554 build ops for a bareword
2555 if we already built the token before, use it.
2560 #pragma segment Perl_yylex
2566 register char *s = PL_bufptr;
2572 SV* tmp = newSVpvs("");
2573 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
2574 (IV)CopLINE(PL_curcop),
2575 lex_state_names[PL_lex_state],
2576 exp_name[PL_expect],
2577 pv_display(tmp, s, strlen(s), 0, 60));
2580 /* check if there's an identifier for us to look at */
2581 if (PL_pending_ident)
2582 return REPORT(S_pending_ident(aTHX));
2584 /* no identifier pending identification */
2586 switch (PL_lex_state) {
2588 case LEX_NORMAL: /* Some compilers will produce faster */
2589 case LEX_INTERPNORMAL: /* code if we comment these out. */
2593 /* when we've already built the next token, just pull it out of the queue */
2596 yylval = NEXTVAL_NEXTTOKE;
2598 PL_lex_state = PL_lex_defer;
2599 PL_expect = PL_lex_expect;
2600 PL_lex_defer = LEX_NORMAL;
2602 return REPORT(PL_nexttype[PL_nexttoke]);
2604 /* interpolated case modifiers like \L \U, including \Q and \E.
2605 when we get here, PL_bufptr is at the \
2607 case LEX_INTERPCASEMOD:
2609 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2610 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2612 /* handle \E or end of string */
2613 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2615 if (PL_lex_casemods) {
2616 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
2617 PL_lex_casestack[PL_lex_casemods] = '\0';
2619 if (PL_bufptr != PL_bufend
2620 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2622 PL_lex_state = LEX_INTERPCONCAT;
2626 if (PL_bufptr != PL_bufend)
2628 PL_lex_state = LEX_INTERPCONCAT;
2632 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2633 "### Saw case modifier\n"); });
2635 if (s[1] == '\\' && s[2] == 'E') {
2637 PL_lex_state = LEX_INTERPCONCAT;
2642 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2643 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2644 if ((*s == 'L' || *s == 'U') &&
2645 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2646 PL_lex_casestack[--PL_lex_casemods] = '\0';
2649 if (PL_lex_casemods > 10)
2650 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2651 PL_lex_casestack[PL_lex_casemods++] = *s;
2652 PL_lex_casestack[PL_lex_casemods] = '\0';
2653 PL_lex_state = LEX_INTERPCONCAT;
2654 NEXTVAL_NEXTTOKE.ival = 0;
2657 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
2659 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
2661 NEXTVAL_NEXTTOKE.ival = OP_LC;
2663 NEXTVAL_NEXTTOKE.ival = OP_UC;
2665 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
2667 Perl_croak(aTHX_ "panic: yylex");
2671 if (PL_lex_starts) {
2674 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2675 if (PL_lex_casemods == 1 && PL_lex_inpat)
2684 case LEX_INTERPPUSH:
2685 return REPORT(sublex_push());
2687 case LEX_INTERPSTART:
2688 if (PL_bufptr == PL_bufend)
2689 return REPORT(sublex_done());
2690 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2691 "### Interpolated variable\n"); });
2693 PL_lex_dojoin = (*PL_bufptr == '@');
2694 PL_lex_state = LEX_INTERPNORMAL;
2695 if (PL_lex_dojoin) {
2696 NEXTVAL_NEXTTOKE.ival = 0;
2698 force_ident("\"", '$');
2699 NEXTVAL_NEXTTOKE.ival = 0;
2701 NEXTVAL_NEXTTOKE.ival = 0;
2703 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
2706 if (PL_lex_starts++) {
2708 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2709 if (!PL_lex_casemods && PL_lex_inpat)
2716 case LEX_INTERPENDMAYBE:
2717 if (intuit_more(PL_bufptr)) {
2718 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2724 if (PL_lex_dojoin) {
2725 PL_lex_dojoin = FALSE;
2726 PL_lex_state = LEX_INTERPCONCAT;
2729 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2730 && SvEVALED(PL_lex_repl))
2732 if (PL_bufptr != PL_bufend)
2733 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2737 case LEX_INTERPCONCAT:
2739 if (PL_lex_brackets)
2740 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2742 if (PL_bufptr == PL_bufend)
2743 return REPORT(sublex_done());
2745 if (SvIVX(PL_linestr) == '\'') {
2746 SV *sv = newSVsv(PL_linestr);
2749 else if ( PL_hints & HINT_NEW_RE )
2750 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2751 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2755 s = scan_const(PL_bufptr);
2757 PL_lex_state = LEX_INTERPCASEMOD;
2759 PL_lex_state = LEX_INTERPSTART;
2762 if (s != PL_bufptr) {
2763 NEXTVAL_NEXTTOKE = yylval;
2766 if (PL_lex_starts++) {
2767 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2768 if (!PL_lex_casemods && PL_lex_inpat)
2781 PL_lex_state = LEX_NORMAL;
2782 s = scan_formline(PL_bufptr);
2783 if (!PL_lex_formbrack)
2789 PL_oldoldbufptr = PL_oldbufptr;
2795 if (isIDFIRST_lazy_if(s,UTF))
2797 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2800 goto fake_eof; /* emulate EOF on ^D or ^Z */
2805 if (PL_lex_brackets) {
2806 yyerror(PL_lex_formbrack
2807 ? "Format not terminated"
2808 : "Missing right curly or square bracket");
2810 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2811 "### Tokener got EOF\n");
2815 if (s++ < PL_bufend)
2816 goto retry; /* ignore stray nulls */
2819 if (!PL_in_eval && !PL_preambled) {
2820 PL_preambled = TRUE;
2821 sv_setpv(PL_linestr,incl_perldb());
2822 if (SvCUR(PL_linestr))
2823 sv_catpvs(PL_linestr,";");
2825 while(AvFILLp(PL_preambleav) >= 0) {
2826 SV *tmpsv = av_shift(PL_preambleav);
2827 sv_catsv(PL_linestr, tmpsv);
2828 sv_catpvs(PL_linestr, ";");
2831 sv_free((SV*)PL_preambleav);
2832 PL_preambleav = NULL;
2834 if (PL_minus_n || PL_minus_p) {
2835 sv_catpvs(PL_linestr, "LINE: while (<>) {");
2837 sv_catpvs(PL_linestr,"chomp;");
2840 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2841 || *PL_splitstr == '"')
2842 && strchr(PL_splitstr + 1, *PL_splitstr))
2843 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2845 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2846 bytes can be used as quoting characters. :-) */
2847 const char *splits = PL_splitstr;
2848 sv_catpvs(PL_linestr, "our @F=split(q\0");
2851 if (*splits == '\\')
2852 sv_catpvn(PL_linestr, splits, 1);
2853 sv_catpvn(PL_linestr, splits, 1);
2854 } while (*splits++);
2855 /* This loop will embed the trailing NUL of
2856 PL_linestr as the last thing it does before
2858 sv_catpvs(PL_linestr, ");");
2862 sv_catpvs(PL_linestr,"our @F=split(' ');");
2866 sv_catpvs(PL_linestr,"use feature ':5.10';");
2867 sv_catpvs(PL_linestr, "\n");
2868 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2869 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2870 PL_last_lop = PL_last_uni = NULL;
2871 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2872 SV * const sv = newSV(0);
2874 sv_upgrade(sv, SVt_PVMG);
2875 sv_setsv(sv,PL_linestr);
2878 av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2883 bof = PL_rsfp ? TRUE : FALSE;
2884 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
2887 if (PL_preprocess && !PL_in_eval)
2888 (void)PerlProc_pclose(PL_rsfp);
2889 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2890 PerlIO_clearerr(PL_rsfp);
2892 (void)PerlIO_close(PL_rsfp);
2894 PL_doextract = FALSE;
2896 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2897 sv_setpv(PL_linestr,PL_minus_p
2898 ? ";}continue{print;}" : ";}");
2899 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2900 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2901 PL_last_lop = PL_last_uni = NULL;
2902 PL_minus_n = PL_minus_p = 0;
2905 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2906 PL_last_lop = PL_last_uni = NULL;
2907 sv_setpvn(PL_linestr,"",0);
2908 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2910 /* If it looks like the start of a BOM or raw UTF-16,
2911 * check if it in fact is. */
2917 #ifdef PERLIO_IS_STDIO
2918 # ifdef __GNU_LIBRARY__
2919 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2920 # define FTELL_FOR_PIPE_IS_BROKEN
2924 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2925 # define FTELL_FOR_PIPE_IS_BROKEN
2930 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2931 /* This loses the possibility to detect the bof
2932 * situation on perl -P when the libc5 is being used.
2933 * Workaround? Maybe attach some extra state to PL_rsfp?
2936 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2938 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2941 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2942 s = swallow_bom((U8*)s);
2946 /* Incest with pod. */
2947 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2948 sv_setpvn(PL_linestr, "", 0);
2949 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2950 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2951 PL_last_lop = PL_last_uni = NULL;
2952 PL_doextract = FALSE;
2956 } while (PL_doextract);
2957 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2958 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2959 SV * const sv = newSV(0);
2961 sv_upgrade(sv, SVt_PVMG);
2962 sv_setsv(sv,PL_linestr);
2965 av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2967 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2968 PL_last_lop = PL_last_uni = NULL;
2969 if (CopLINE(PL_curcop) == 1) {
2970 while (s < PL_bufend && isSPACE(*s))
2972 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2976 if (*s == '#' && *(s+1) == '!')
2978 #ifdef ALTERNATE_SHEBANG
2980 static char const as[] = ALTERNATE_SHEBANG;
2981 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2982 d = s + (sizeof(as) - 1);
2984 #endif /* ALTERNATE_SHEBANG */
2993 while (*d && !isSPACE(*d))
2997 #ifdef ARG_ZERO_IS_SCRIPT
2998 if (ipathend > ipath) {
3000 * HP-UX (at least) sets argv[0] to the script name,
3001 * which makes $^X incorrect. And Digital UNIX and Linux,
3002 * at least, set argv[0] to the basename of the Perl
3003 * interpreter. So, having found "#!", we'll set it right.
3005 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3007 assert(SvPOK(x) || SvGMAGICAL(x));
3008 if (sv_eq(x, CopFILESV(PL_curcop))) {
3009 sv_setpvn(x, ipath, ipathend - ipath);
3015 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3016 const char * const lstart = SvPV_const(x,llen);
3018 bstart += blen - llen;
3019 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3020 sv_setpvn(x, ipath, ipathend - ipath);
3025 TAINT_NOT; /* $^X is always tainted, but that's OK */
3027 #endif /* ARG_ZERO_IS_SCRIPT */
3032 d = instr(s,"perl -");
3034 d = instr(s,"perl");
3036 /* avoid getting into infinite loops when shebang
3037 * line contains "Perl" rather than "perl" */
3039 for (d = ipathend-4; d >= ipath; --d) {
3040 if ((*d == 'p' || *d == 'P')
3041 && !ibcmp(d, "perl", 4))
3051 #ifdef ALTERNATE_SHEBANG
3053 * If the ALTERNATE_SHEBANG on this system starts with a
3054 * character that can be part of a Perl expression, then if
3055 * we see it but not "perl", we're probably looking at the
3056 * start of Perl code, not a request to hand off to some
3057 * other interpreter. Similarly, if "perl" is there, but
3058 * not in the first 'word' of the line, we assume the line
3059 * contains the start of the Perl program.
3061 if (d && *s != '#') {
3062 const char *c = ipath;
3063 while (*c && !strchr("; \t\r\n\f\v#", *c))
3066 d = NULL; /* "perl" not in first word; ignore */
3068 *s = '#'; /* Don't try to parse shebang line */
3070 #endif /* ALTERNATE_SHEBANG */
3071 #ifndef MACOS_TRADITIONAL
3076 !instr(s,"indir") &&
3077 instr(PL_origargv[0],"perl"))
3084 while (s < PL_bufend && isSPACE(*s))
3086 if (s < PL_bufend) {
3087 Newxz(newargv,PL_origargc+3,char*);
3089 while (s < PL_bufend && !isSPACE(*s))
3092 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3095 newargv = PL_origargv;
3098 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3100 Perl_croak(aTHX_ "Can't exec %s", ipath);
3104 while (*d && !isSPACE(*d)) d++;
3105 while (SPACE_OR_TAB(*d)) d++;
3108 const bool switches_done = PL_doswitches;
3109 const U32 oldpdb = PL_perldb;
3110 const bool oldn = PL_minus_n;
3111 const bool oldp = PL_minus_p;
3114 if (*d == 'M' || *d == 'm' || *d == 'C') {
3115 const char * const m = d;
3116 while (*d && !isSPACE(*d)) d++;
3117 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3120 d = moreswitches(d);
3122 if (PL_doswitches && !switches_done) {
3123 int argc = PL_origargc;
3124 char **argv = PL_origargv;
3127 } while (argc && argv[0][0] == '-' && argv[0][1]);
3128 init_argv_symbols(argc,argv);
3130 if ((PERLDB_LINE && !oldpdb) ||
3131 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3132 /* if we have already added "LINE: while (<>) {",
3133 we must not do it again */
3135 sv_setpvn(PL_linestr, "", 0);
3136 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3137 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3138 PL_last_lop = PL_last_uni = NULL;
3139 PL_preambled = FALSE;
3141 (void)gv_fetchfile(PL_origfilename);
3148 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3150 PL_lex_state = LEX_FORMLINE;
3155 #ifdef PERL_STRICT_CR
3156 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3158 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3160 case ' ': case '\t': case '\f': case 013:
3161 #ifdef MACOS_TRADITIONAL
3168 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3169 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3170 /* handle eval qq[#line 1 "foo"\n ...] */
3171 CopLINE_dec(PL_curcop);
3175 while (s < d && *s != '\n')
3179 else if (s > d) /* Found by Ilya: feed random input to Perl. */
3180 Perl_croak(aTHX_ "panic: input overflow");
3182 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3184 PL_lex_state = LEX_FORMLINE;
3194 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3202 while (s < PL_bufend && SPACE_OR_TAB(*s))
3205 if (strnEQ(s,"=>",2)) {
3206 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3207 DEBUG_T( { S_printbuf(aTHX_
3208 "### Saw unary minus before =>, forcing word %s\n", s);
3210 OPERATOR('-'); /* unary minus */
3212 PL_last_uni = PL_oldbufptr;
3214 case 'r': ftst = OP_FTEREAD; break;
3215 case 'w': ftst = OP_FTEWRITE; break;
3216 case 'x': ftst = OP_FTEEXEC; break;
3217 case 'o': ftst = OP_FTEOWNED; break;
3218 case 'R': ftst = OP_FTRREAD; break;
3219 case 'W': ftst = OP_FTRWRITE; break;
3220 case 'X': ftst = OP_FTREXEC; break;
3221 case 'O': ftst = OP_FTROWNED; break;
3222 case 'e': ftst = OP_FTIS; break;
3223 case 'z': ftst = OP_FTZERO; break;
3224 case 's': ftst = OP_FTSIZE; break;
3225 case 'f': ftst = OP_FTFILE; break;
3226 case 'd': ftst = OP_FTDIR; break;
3227 case 'l': ftst = OP_FTLINK; break;
3228 case 'p': ftst = OP_FTPIPE; break;
3229 case 'S': ftst = OP_FTSOCK; break;
3230 case 'u': ftst = OP_FTSUID; break;
3231 case 'g': ftst = OP_FTSGID; break;
3232 case 'k': ftst = OP_FTSVTX; break;
3233 case 'b': ftst = OP_FTBLK; break;
3234 case 'c': ftst = OP_FTCHR; break;
3235 case 't': ftst = OP_FTTTY; break;
3236 case 'T': ftst = OP_FTTEXT; break;
3237 case 'B': ftst = OP_FTBINARY; break;
3238 case 'M': case 'A': case 'C':
3239 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
3241 case 'M': ftst = OP_FTMTIME; break;
3242 case 'A': ftst = OP_FTATIME; break;
3243 case 'C': ftst = OP_FTCTIME; break;
3251 PL_last_lop_op = (OPCODE)ftst;
3252 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3253 "### Saw file test %c\n", (int)tmp);
3258 /* Assume it was a minus followed by a one-letter named
3259 * subroutine call (or a -bareword), then. */
3260 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3261 "### '-%c' looked like a file test but was not\n",
3268 const char tmp = *s++;
3271 if (PL_expect == XOPERATOR)
3276 else if (*s == '>') {
3279 if (isIDFIRST_lazy_if(s,UTF)) {
3280 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3288 if (PL_expect == XOPERATOR)
3291 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3293 OPERATOR('-'); /* unary minus */
3299 const char tmp = *s++;
3302 if (PL_expect == XOPERATOR)
3307 if (PL_expect == XOPERATOR)
3310 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3317 if (PL_expect != XOPERATOR) {
3318 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3319 PL_expect = XOPERATOR;
3320 force_ident(PL_tokenbuf, '*');
3333 if (PL_expect == XOPERATOR) {
3337 PL_tokenbuf[0] = '%';
3338 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3339 if (!PL_tokenbuf[1]) {
3342 PL_pending_ident = '%';
3353 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
3354 && FEATURE_IS_ENABLED("~~"))
3361 const char tmp = *s++;
3367 goto just_a_word_zero_gv;
3370 switch (PL_expect) {
3373 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3375 PL_bufptr = s; /* update in case we back off */
3381 PL_expect = XTERMBLOCK;
3385 while (isIDFIRST_lazy_if(s,UTF)) {
3387 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3388 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3389 if (tmp < 0) tmp = -tmp;
3405 d = scan_str(d,TRUE,TRUE);
3407 /* MUST advance bufptr here to avoid bogus
3408 "at end of line" context messages from yyerror().
3410 PL_bufptr = s + len;
3411 yyerror("Unterminated attribute parameter in attribute list");
3414 return REPORT(0); /* EOF indicator */
3418 SV *sv = newSVpvn(s, len);
3419 sv_catsv(sv, PL_lex_stuff);
3420 attrs = append_elem(OP_LIST, attrs,
3421 newSVOP(OP_CONST, 0, sv));
3422 SvREFCNT_dec(PL_lex_stuff);
3423 PL_lex_stuff = NULL;
3426 if (len == 6 && strnEQ(s, "unique", len)) {
3427 if (PL_in_my == KEY_our)
3429 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3431 /*EMPTY*/; /* skip to avoid loading attributes.pm */
3434 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3437 /* NOTE: any CV attrs applied here need to be part of
3438 the CVf_BUILTIN_ATTRS define in cv.h! */
3439 else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3440 CvLVALUE_on(PL_compcv);
3441 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3442 CvLOCKED_on(PL_compcv);
3443 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3444 CvMETHOD_on(PL_compcv);
3445 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3446 CvASSERTION_on(PL_compcv);
3447 /* After we've set the flags, it could be argued that
3448 we don't need to do the attributes.pm-based setting
3449 process, and shouldn't bother appending recognized
3450 flags. To experiment with that, uncomment the
3451 following "else". (Note that's already been
3452 uncommented. That keeps the above-applied built-in
3453 attributes from being intercepted (and possibly
3454 rejected) by a package's attribute routines, but is
3455 justified by the performance win for the common case
3456 of applying only built-in attributes.) */
3458 attrs = append_elem(OP_LIST, attrs,
3459 newSVOP(OP_CONST, 0,
3463 if (*s == ':' && s[1] != ':')
3466 break; /* require real whitespace or :'s */
3467 /* XXX losing whitespace on sequential attributes here */
3471 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3472 if (*s != ';' && *s != '}' && *s != tmp
3473 && (tmp != '=' || *s != ')')) {
3474 const char q = ((*s == '\'') ? '"' : '\'');
3475 /* If here for an expression, and parsed no attrs, back
3477 if (tmp == '=' && !attrs) {
3481 /* MUST advance bufptr here to avoid bogus "at end of line"
3482 context messages from yyerror().
3486 ? Perl_form(aTHX_ "Invalid separator character "
3487 "%c%c%c in attribute list", q, *s, q)
3488 : "Unterminated attribute list" );
3496 NEXTVAL_NEXTTOKE.opval = attrs;
3504 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3505 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3513 const char tmp = *s++;
3518 const char tmp = *s++;
3526 if (PL_lex_brackets <= 0)
3527 yyerror("Unmatched right square bracket");
3530 if (PL_lex_state == LEX_INTERPNORMAL) {
3531 if (PL_lex_brackets == 0) {
3532 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3533 PL_lex_state = LEX_INTERPEND;
3540 if (PL_lex_brackets > 100) {
3541 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3543 switch (PL_expect) {
3545 if (PL_lex_formbrack) {
3549 if (PL_oldoldbufptr == PL_last_lop)
3550 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3552 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3553 OPERATOR(HASHBRACK);
3555 while (s < PL_bufend && SPACE_OR_TAB(*s))
3558 PL_tokenbuf[0] = '\0';
3559 if (d < PL_bufend && *d == '-') {
3560 PL_tokenbuf[0] = '-';
3562 while (d < PL_bufend && SPACE_OR_TAB(*d))
3565 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3566 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3568 while (d < PL_bufend && SPACE_OR_TAB(*d))
3571 const char minus = (PL_tokenbuf[0] == '-');
3572 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3580 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3585 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3590 if (PL_oldoldbufptr == PL_last_lop)
3591 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3593 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3596 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3598 /* This hack is to get the ${} in the message. */
3600 yyerror("syntax error");
3603 OPERATOR(HASHBRACK);
3605 /* This hack serves to disambiguate a pair of curlies
3606 * as being a block or an anon hash. Normally, expectation
3607 * determines that, but in cases where we're not in a
3608 * position to expect anything in particular (like inside
3609 * eval"") we have to resolve the ambiguity. This code
3610 * covers the case where the first term in the curlies is a
3611 * quoted string. Most other cases need to be explicitly
3612 * disambiguated by prepending a "+" before the opening
3613 * curly in order to force resolution as an anon hash.
3615 * XXX should probably propagate the outer expectation
3616 * into eval"" to rely less on this hack, but that could
3617 * potentially break current behavior of eval"".
3621 if (*s == '\'' || *s == '"' || *s == '`') {
3622 /* common case: get past first string, handling escapes */
3623 for (t++; t < PL_bufend && *t != *s;)
3624 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3628 else if (*s == 'q') {
3631 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3634 /* skip q//-like construct */
3636 char open, close, term;
3639 while (t < PL_bufend && isSPACE(*t))
3641 /* check for q => */
3642 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3643 OPERATOR(HASHBRACK);
3647 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3651 for (t++; t < PL_bufend; t++) {
3652 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3654 else if (*t == open)
3658 for (t++; t < PL_bufend; t++) {
3659 if (*t == '\\' && t+1 < PL_bufend)
3661 else if (*t == close && --brackets <= 0)
3663 else if (*t == open)
3670 /* skip plain q word */
3671 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3674 else if (isALNUM_lazy_if(t,UTF)) {
3676 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3679 while (t < PL_bufend && isSPACE(*t))
3681 /* if comma follows first term, call it an anon hash */
3682 /* XXX it could be a comma expression with loop modifiers */
3683 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3684 || (*t == '=' && t[1] == '>')))
3685 OPERATOR(HASHBRACK);
3686 if (PL_expect == XREF)
3689 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3695 yylval.ival = CopLINE(PL_curcop);
3696 if (isSPACE(*s) || *s == '#')
3697 PL_copline = NOLINE; /* invalidate current command line number */
3702 if (PL_lex_brackets <= 0)
3703 yyerror("Unmatched right curly bracket");
3705 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3706 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3707 PL_lex_formbrack = 0;
3708 if (PL_lex_state == LEX_INTERPNORMAL) {
3709 if (PL_lex_brackets == 0) {
3710 if (PL_expect & XFAKEBRACK) {
3711 PL_expect &= XENUMMASK;
3712 PL_lex_state = LEX_INTERPEND;
3714 return yylex(); /* ignore fake brackets */
3716 if (*s == '-' && s[1] == '>')
3717 PL_lex_state = LEX_INTERPENDMAYBE;
3718 else if (*s != '[' && *s != '{')
3719 PL_lex_state = LEX_INTERPEND;
3722 if (PL_expect & XFAKEBRACK) {
3723 PL_expect &= XENUMMASK;
3725 return yylex(); /* ignore fake brackets */
3734 if (PL_expect == XOPERATOR) {
3735 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
3736 && isIDFIRST_lazy_if(s,UTF))
3738 CopLINE_dec(PL_curcop);
3739 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3740 CopLINE_inc(PL_curcop);
3745 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3747 PL_expect = XOPERATOR;
3748 force_ident(PL_tokenbuf, '&');
3752 yylval.ival = (OPpENTERSUB_AMPER<<8);
3764 const char tmp = *s++;
3771 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
3772 && strchr("+-*/%.^&|<",tmp))
3773 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3774 "Reversed %c= operator",(int)tmp);
3776 if (PL_expect == XSTATE && isALPHA(tmp) &&
3777 (s == PL_linestart+1 || s[-2] == '\n') )
3779 if (PL_in_eval && !PL_rsfp) {
3784 if (strnEQ(s,"=cut",4)) {
3798 PL_doextract = TRUE;
3802 if (PL_lex_brackets < PL_lex_formbrack) {
3804 #ifdef PERL_STRICT_CR
3805 for (t = s; SPACE_OR_TAB(*t); t++) ;
3807 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3809 if (*t == '\n' || *t == '#') {
3820 const char tmp = *s++;
3822 /* was this !=~ where !~ was meant?
3823 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3825 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3826 const char *t = s+1;
3828 while (t < PL_bufend && isSPACE(*t))
3831 if (*t == '/' || *t == '?' ||
3832 ((*t == 'm' || *t == 's' || *t == 'y')
3833 && !isALNUM(t[1])) ||
3834 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3835 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3836 "!=~ should be !~");
3846 if (PL_expect != XOPERATOR) {
3847 if (s[1] != '<' && !strchr(s,'>'))
3850 s = scan_heredoc(s);
3852 s = scan_inputsymbol(s);
3853 TERM(sublex_start());
3859 SHop(OP_LEFT_SHIFT);
3873 const char tmp = *s++;
3875 SHop(OP_RIGHT_SHIFT);
3885 if (PL_expect == XOPERATOR) {
3886 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3888 deprecate_old(commaless_variable_list);
3889 return REPORT(','); /* grandfather non-comma-format format */
3893 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3894 PL_tokenbuf[0] = '@';
3895 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3896 sizeof PL_tokenbuf - 1, FALSE);
3897 if (PL_expect == XOPERATOR)
3898 no_op("Array length", s);
3899 if (!PL_tokenbuf[1])
3901 PL_expect = XOPERATOR;
3902 PL_pending_ident = '#';
3906 PL_tokenbuf[0] = '$';
3907 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3908 sizeof PL_tokenbuf - 1, FALSE);
3909 if (PL_expect == XOPERATOR)
3911 if (!PL_tokenbuf[1]) {
3913 yyerror("Final $ should be \\$ or $name");
3917 /* This kludge not intended to be bulletproof. */
3918 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3919 yylval.opval = newSVOP(OP_CONST, 0,
3920 newSViv(PL_compiling.cop_arybase));
3921 yylval.opval->op_private = OPpCONST_ARYBASE;
3927 const char tmp = *s;
3928 if (PL_lex_state == LEX_NORMAL)
3931 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
3932 && intuit_more(s)) {
3934 PL_tokenbuf[0] = '@';
3935 if (ckWARN(WARN_SYNTAX)) {
3938 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3941 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
3942 while (t < PL_bufend && *t != ']')
3944 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3945 "Multidimensional syntax %.*s not supported",
3946 (int)((t - PL_bufptr) + 1), PL_bufptr);
3950 else if (*s == '{') {
3952 PL_tokenbuf[0] = '%';
3953 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
3954 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
3956 char tmpbuf[sizeof PL_tokenbuf];
3957 for (t++; isSPACE(*t); t++) ;
3958 if (isIDFIRST_lazy_if(t,UTF)) {
3960 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
3962 for (; isSPACE(*t); t++) ;
3963 if (*t == ';' && get_cv(tmpbuf, FALSE))
3964 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3965 "You need to quote \"%s\"",
3972 PL_expect = XOPERATOR;
3973 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3974 const bool islop = (PL_last_lop == PL_oldoldbufptr);
3975 if (!islop || PL_last_lop_op == OP_GREPSTART)
3976 PL_expect = XOPERATOR;
3977 else if (strchr("$@\"'`q", *s))
3978 PL_expect = XTERM; /* e.g. print $fh "foo" */
3979 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3980 PL_expect = XTERM; /* e.g. print $fh &sub */
3981 else if (isIDFIRST_lazy_if(s,UTF)) {
3982 char tmpbuf[sizeof PL_tokenbuf];
3984 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3985 if ((t2 = keyword(tmpbuf, len))) {
3986 /* binary operators exclude handle interpretations */
3998 PL_expect = XTERM; /* e.g. print $fh length() */
4003 PL_expect = XTERM; /* e.g. print $fh subr() */
4006 else if (isDIGIT(*s))
4007 PL_expect = XTERM; /* e.g. print $fh 3 */
4008 else if (*s == '.' && isDIGIT(s[1]))
4009 PL_expect = XTERM; /* e.g. print $fh .3 */
4010 else if ((*s == '?' || *s == '-' || *s == '+')
4011 && !isSPACE(s[1]) && s[1] != '=')
4012 PL_expect = XTERM; /* e.g. print $fh -1 */
4013 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4015 PL_expect = XTERM; /* e.g. print $fh /.../
4016 XXX except DORDOR operator
4018 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4020 PL_expect = XTERM; /* print $fh <<"EOF" */
4023 PL_pending_ident = '$';
4027 if (PL_expect == XOPERATOR)
4029 PL_tokenbuf[0] = '@';
4030 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4031 if (!PL_tokenbuf[1]) {
4034 if (PL_lex_state == LEX_NORMAL)
4036 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4038 PL_tokenbuf[0] = '%';
4040 /* Warn about @ where they meant $. */
4041 if (*s == '[' || *s == '{') {
4042 if (ckWARN(WARN_SYNTAX)) {
4043 const char *t = s + 1;
4044 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4046 if (*t == '}' || *t == ']') {
4048 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4049 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4050 "Scalar value %.*s better written as $%.*s",
4051 (int)(t-PL_bufptr), PL_bufptr,
4052 (int)(t-PL_bufptr-1), PL_bufptr+1);
4057 PL_pending_ident = '@';
4060 case '/': /* may be division, defined-or, or pattern */
4061 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4065 case '?': /* may either be conditional or pattern */
4066 if(PL_expect == XOPERATOR) {
4074 /* A // operator. */
4084 /* Disable warning on "study /blah/" */
4085 if (PL_oldoldbufptr == PL_last_uni
4086 && (*PL_last_uni != 's' || s - PL_last_uni < 5
4087 || memNE(PL_last_uni, "study", 5)
4088 || isALNUM_lazy_if(PL_last_uni+5,UTF)
4091 s = scan_pat(s,OP_MATCH);
4092 TERM(sublex_start());
4096 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4097 #ifdef PERL_STRICT_CR
4100 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4102 && (s == PL_linestart || s[-1] == '\n') )
4104 PL_lex_formbrack = 0;
4108 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
4114 yylval.ival = OPf_SPECIAL;
4120 if (PL_expect != XOPERATOR)
4125 case '0': case '1': case '2': case '3': case '4':
4126 case '5': case '6': case '7': case '8': case '9':
4127 s = scan_num(s, &yylval);
4128 DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
4129 if (PL_expect == XOPERATOR)
4134 s = scan_str(s,FALSE,FALSE);
4135 DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
4136 if (PL_expect == XOPERATOR) {
4137 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4139 deprecate_old(commaless_variable_list);
4140 return REPORT(','); /* grandfather non-comma-format format */
4146 missingterm((char*)0);
4147 yylval.ival = OP_CONST;
4148 TERM(sublex_start());
4151 s = scan_str(s,FALSE,FALSE);
4152 DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
4153 if (PL_expect == XOPERATOR) {
4154 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4156 deprecate_old(commaless_variable_list);
4157 return REPORT(','); /* grandfather non-comma-format format */
4163 missingterm((char*)0);
4164 yylval.ival = OP_CONST;
4165 /* FIXME. I think that this can be const if char *d is replaced by
4166 more localised variables. */
4167 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
4168 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
4169 yylval.ival = OP_STRINGIFY;
4173 TERM(sublex_start());
4176 s = scan_str(s,FALSE,FALSE);
4177 DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
4178 if (PL_expect == XOPERATOR)
4179 no_op("Backticks",s);
4181 missingterm((char*)0);
4182 yylval.ival = OP_BACKTICK;
4184 TERM(sublex_start());
4188 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
4189 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
4191 if (PL_expect == XOPERATOR)
4192 no_op("Backslash",s);
4196 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
4197 char *start = s + 2;
4198 while (isDIGIT(*start) || *start == '_')
4200 if (*start == '.' && isDIGIT(start[1])) {
4201 s = scan_num(s, &yylval);
4204 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
4205 else if (!isALPHA(*start) && (PL_expect == XTERM
4206 || PL_expect == XREF || PL_expect == XSTATE
4207 || PL_expect == XTERMORDORDOR)) {
4208 const char c = *start;
4211 gv = gv_fetchpv(s, 0, SVt_PVCV);
4214 s = scan_num(s, &yylval);
4221 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
4257 I32 orig_keyword = 0;
4262 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4264 /* Some keywords can be followed by any delimiter, including ':' */
4265 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4266 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4267 (PL_tokenbuf[0] == 'q' &&
4268 strchr("qwxr", PL_tokenbuf[1])))));
4270 /* x::* is just a word, unless x is "CORE" */
4271 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4275 while (d < PL_bufend && isSPACE(*d))
4276 d++; /* no comments skipped here, or s### is misparsed */
4278 /* Is this a label? */
4279 if (!tmp && PL_expect == XSTATE
4280 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4282 yylval.pval = savepv(PL_tokenbuf);
4287 /* Check for keywords */
4288 tmp = keyword(PL_tokenbuf, len);
4290 /* Is this a word before a => operator? */
4291 if (*d == '=' && d[1] == '>') {
4294 = (OP*)newSVOP(OP_CONST, 0,
4295 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4296 yylval.opval->op_private = OPpCONST_BARE;
4300 if (tmp < 0) { /* second-class keyword? */
4301 GV *ogv = NULL; /* override (winner) */
4302 GV *hgv = NULL; /* hidden (loser) */
4303 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4305 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
4308 if (GvIMPORTED_CV(gv))
4310 else if (! CvMETHOD(cv))
4314 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4315 (gv = *gvp) != (GV*)&PL_sv_undef &&
4316 GvCVu(gv) && GvIMPORTED_CV(gv))
4323 tmp = 0; /* overridden by import or by GLOBAL */
4326 && -tmp==KEY_lock /* XXX generalizable kludge */
4328 && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
4330 tmp = 0; /* any sub overrides "weak" keyword */
4332 else { /* no override */
4334 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4335 Perl_warner(aTHX_ packWARN(WARN_MISC),
4336 "dump() better written as CORE::dump()");
4340 if (hgv && tmp != KEY_x && tmp != KEY_CORE
4341 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
4342 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4343 "Ambiguous call resolved as CORE::%s(), %s",
4344 GvENAME(hgv), "qualify as such or use &");
4351 default: /* not a keyword */
4352 /* Trade off - by using this evil construction we can pull the
4353 variable gv into the block labelled keylookup. If not, then
4354 we have to give it function scope so that the goto from the
4355 earlier ':' case doesn't bypass the initialisation. */
4357 just_a_word_zero_gv:
4365 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4368 /* Get the rest if it looks like a package qualifier */
4370 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4372 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4375 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4376 *s == '\'' ? "'" : "::");
4381 if (PL_expect == XOPERATOR) {
4382 if (PL_bufptr == PL_linestart) {
4383 CopLINE_dec(PL_curcop);
4384 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4385 CopLINE_inc(PL_curcop);
4388 no_op("Bareword",s);
4391 /* Look for a subroutine with this name in current package,
4392 unless name is "Foo::", in which case Foo is a bearword
4393 (and a package name). */
4396 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4398 if (ckWARN(WARN_BAREWORD)
4399 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
4400 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4401 "Bareword \"%s\" refers to nonexistent package",
4404 PL_tokenbuf[len] = '\0';
4410 /* Mustn't actually add anything to a symbol table.
4411 But also don't want to "initialise" any placeholder
4412 constants that might already be there into full
4413 blown PVGVs with attached PVCV. */
4414 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
4415 GV_NOADD_NOINIT, SVt_PVCV);
4420 /* if we saw a global override before, get the right name */
4423 sv = newSVpvs("CORE::GLOBAL::");
4424 sv_catpv(sv,PL_tokenbuf);
4427 /* If len is 0, newSVpv does strlen(), which is correct.
4428 If len is non-zero, then it will be the true length,
4429 and so the scalar will be created correctly. */
4430 sv = newSVpv(PL_tokenbuf,len);
4433 /* Presume this is going to be a bareword of some sort. */
4436 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4437 yylval.opval->op_private = OPpCONST_BARE;
4438 /* UTF-8 package name? */
4439 if (UTF && !IN_BYTES &&
4440 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
4443 /* And if "Foo::", then that's what it certainly is. */
4448 /* Do the explicit type check so that we don't need to force
4449 the initialisation of the symbol table to have a real GV.
4450 Beware - gv may not really be a PVGV, cv may not really be
4451 a PVCV, (because of the space optimisations that gv_init
4452 understands) But they're true if for this symbol there is
4453 respectively a typeglob and a subroutine.
4455 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
4456 /* Real typeglob, so get the real subroutine: */
4458 /* A proxy for a subroutine in this package? */
4459 : SvOK(gv) ? (CV *) gv : NULL)
4462 /* See if it's the indirect object for a list operator. */
4464 if (PL_oldoldbufptr &&
4465 PL_oldoldbufptr < PL_bufptr &&
4466 (PL_oldoldbufptr == PL_last_lop
4467 || PL_oldoldbufptr == PL_last_uni) &&
4468 /* NO SKIPSPACE BEFORE HERE! */
4469 (PL_expect == XREF ||
4470 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4472 bool immediate_paren = *s == '(';
4474 /* (Now we can afford to cross potential line boundary.) */
4475 s = SKIPSPACE2(s,nextnextwhite);
4477 /* Two barewords in a row may indicate method call. */
4479 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
4480 (tmp = intuit_method(s, gv, cv)))
4483 /* If not a declared subroutine, it's an indirect object. */
4484 /* (But it's an indir obj regardless for sort.) */
4485 /* Also, if "_" follows a filetest operator, it's a bareword */
4488 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4490 (PL_last_lop_op != OP_MAPSTART &&
4491 PL_last_lop_op != OP_GREPSTART))))
4492 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
4493 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
4496 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4501 PL_expect = XOPERATOR;
4504 /* Is this a word before a => operator? */
4505 if (*s == '=' && s[1] == '>' && !pkgname) {
4507 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4508 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4509 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4513 /* If followed by a paren, it's certainly a subroutine. */
4517 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4518 if (*d == ')' && (sv = gv_const_sv(gv))) {
4523 NEXTVAL_NEXTTOKE.opval = yylval.opval;
4524 PL_expect = XOPERATOR;
4530 /* If followed by var or block, call it a method (unless sub) */
4532 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
4533 PL_last_lop = PL_oldbufptr;
4534 PL_last_lop_op = OP_METHOD;
4538 /* If followed by a bareword, see if it looks like indir obj. */
4541 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4542 && (tmp = intuit_method(s, gv, cv)))
4545 /* Not a method, so call it a subroutine (if defined) */
4548 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4549 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4550 "Ambiguous use of -%s resolved as -&%s()",
4551 PL_tokenbuf, PL_tokenbuf);
4552 /* Check for a constant sub */
4553 if ((sv = gv_const_sv(gv))) {
4555 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4556 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
4557 yylval.opval->op_private = 0;
4561 /* Resolve to GV now. */
4562 if (SvTYPE(gv) != SVt_PVGV) {
4563 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
4564 assert (SvTYPE(gv) == SVt_PVGV);
4565 /* cv must have been some sort of placeholder, so
4566 now needs replacing with a real code reference. */
4570 op_free(yylval.opval);
4571 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4572 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4573 PL_last_lop = PL_oldbufptr;
4574 PL_last_lop_op = OP_ENTERSUB;
4575 /* Is there a prototype? */
4578 const char *proto = SvPV_const((SV*)cv, protolen);
4581 if (*proto == '$' && proto[1] == '\0')
4583 while (*proto == ';')
4585 if (*proto == '&' && *s == '{') {
4586 sv_setpv(PL_subname, PL_curstash ?
4587 "__ANON__" : "__ANON__::__ANON__");
4591 NEXTVAL_NEXTTOKE.opval = yylval.opval;
4597 /* Call it a bare word */
4599 if (PL_hints & HINT_STRICT_SUBS)
4600 yylval.opval->op_private |= OPpCONST_STRICT;
4603 if (lastchar != '-') {
4604 if (ckWARN(WARN_RESERVED)) {
4605 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4606 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4607 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4614 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4615 && ckWARN_d(WARN_AMBIGUOUS)) {
4616 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4617 "Operator or semicolon missing before %c%s",
4618 lastchar, PL_tokenbuf);
4619 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4620 "Ambiguous use of %c resolved as operator %c",
4621 lastchar, lastchar);
4627 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4628 newSVpv(CopFILE(PL_curcop),0));
4632 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4633 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4636 case KEY___PACKAGE__:
4637 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4639 ? newSVhek(HvNAME_HEK(PL_curstash))
4646 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4647 const char *pname = "main";
4648 if (PL_tokenbuf[2] == 'D')
4649 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
4650 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
4654 GvIOp(gv) = newIO();
4655 IoIFP(GvIOp(gv)) = PL_rsfp;
4656 #if defined(HAS_FCNTL) && defined(F_SETFD)
4658 const int fd = PerlIO_fileno(PL_rsfp);
4659 fcntl(fd,F_SETFD,fd >= 3);
4662 /* Mark this internal pseudo-handle as clean */
4663 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4665 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4666 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4667 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4669 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4670 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4671 /* if the script was opened in binmode, we need to revert
4672 * it to text mode for compatibility; but only iff it has CRs
4673 * XXX this is a questionable hack at best. */
4674 if (PL_bufend-PL_bufptr > 2
4675 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4678 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4679 loc = PerlIO_tell(PL_rsfp);
4680 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4683 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4685 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4686 #endif /* NETWARE */
4687 #ifdef PERLIO_IS_STDIO /* really? */
4688 # if defined(__BORLANDC__)
4689 /* XXX see note in do_binmode() */
4690 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4694 PerlIO_seek(PL_rsfp, loc, 0);
4698 #ifdef PERLIO_LAYERS
4701 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4702 else if (PL_encoding) {
4709 XPUSHs(PL_encoding);
4711 call_method("name", G_SCALAR);
4715 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4716 Perl_form(aTHX_ ":encoding(%"SVf")",
4734 if (PL_expect == XSTATE) {
4741 if (*s == ':' && s[1] == ':') {
4744 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4745 if (!(tmp = keyword(PL_tokenbuf, len)))
4746 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4749 else if (tmp == KEY_require || tmp == KEY_do)
4750 /* that's a way to remember we saw "CORE::" */
4763 LOP(OP_ACCEPT,XTERM);
4769 LOP(OP_ATAN2,XTERM);
4775 LOP(OP_BINMODE,XTERM);
4778 LOP(OP_BLESS,XTERM);
4787 /* When 'use switch' is in effect, continue has a dual
4788 life as a control operator. */
4790 if (!FEATURE_IS_ENABLED("switch"))
4793 /* We have to disambiguate the two senses of
4794 "continue". If the next token is a '{' then
4795 treat it as the start of a continue block;
4796 otherwise treat it as a control operator.
4808 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
4825 if (!PL_cryptseen) {
4826 PL_cryptseen = TRUE;
4830 LOP(OP_CRYPT,XTERM);
4833 LOP(OP_CHMOD,XTERM);
4836 LOP(OP_CHOWN,XTERM);
4839 LOP(OP_CONNECT,XTERM);
4858 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4859 if (orig_keyword == KEY_do) {
4868 PL_hints |= HINT_BLOCK_SCOPE;
4878 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4879 LOP(OP_DBMOPEN,XTERM);
4885 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4892 yylval.ival = CopLINE(PL_curcop);
4906 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4907 UNIBRACK(OP_ENTEREVAL);
4925 case KEY_endhostent:
4931 case KEY_endservent:
4934 case KEY_endprotoent:
4945 yylval.ival = CopLINE(PL_curcop);
4947 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4949 if ((PL_bufend - p) >= 3 &&
4950 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4952 else if ((PL_bufend - p) >= 4 &&
4953 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4956 if (isIDFIRST_lazy_if(p,UTF)) {
4957 p = scan_ident(p, PL_bufend,
4958 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4962 Perl_croak(aTHX_ "Missing $ on loop variable");
4967 LOP(OP_FORMLINE,XTERM);
4973 LOP(OP_FCNTL,XTERM);
4979 LOP(OP_FLOCK,XTERM);
4988 LOP(OP_GREPSTART, XREF);
4991 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5006 case KEY_getpriority:
5007 LOP(OP_GETPRIORITY,XTERM);
5009 case KEY_getprotobyname:
5012 case KEY_getprotobynumber:
5013 LOP(OP_GPBYNUMBER,XTERM);
5015 case KEY_getprotoent:
5027 case KEY_getpeername:
5028 UNI(OP_GETPEERNAME);
5030 case KEY_gethostbyname:
5033 case KEY_gethostbyaddr:
5034 LOP(OP_GHBYADDR,XTERM);
5036 case KEY_gethostent:
5039 case KEY_getnetbyname:
5042 case KEY_getnetbyaddr:
5043 LOP(OP_GNBYADDR,XTERM);
5048 case KEY_getservbyname:
5049 LOP(OP_GSBYNAME,XTERM);
5051 case KEY_getservbyport:
5052 LOP(OP_GSBYPORT,XTERM);
5054 case KEY_getservent:
5057 case KEY_getsockname:
5058 UNI(OP_GETSOCKNAME);
5060 case KEY_getsockopt:
5061 LOP(OP_GSOCKOPT,XTERM);
5076 yylval.ival = CopLINE(PL_curcop);
5087 yylval.ival = CopLINE(PL_curcop);
5091 LOP(OP_INDEX,XTERM);
5097 LOP(OP_IOCTL,XTERM);
5109 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5141 LOP(OP_LISTEN,XTERM);
5150 s = scan_pat(s,OP_MATCH);
5151 TERM(sublex_start());
5154 LOP(OP_MAPSTART, XREF);
5157 LOP(OP_MKDIR,XTERM);
5160 LOP(OP_MSGCTL,XTERM);
5163 LOP(OP_MSGGET,XTERM);
5166 LOP(OP_MSGRCV,XTERM);
5169 LOP(OP_MSGSND,XTERM);
5175 if (isIDFIRST_lazy_if(s,UTF)) {
5176 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
5177 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
5179 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
5180 if (!PL_in_my_stash) {
5183 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
5191 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5198 s = tokenize_use(0, s);
5202 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
5209 if (isIDFIRST_lazy_if(s,UTF)) {
5211 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
5212 for (t=d; *t && isSPACE(*t); t++) ;
5213 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
5215 && !(t[0] == '=' && t[1] == '>')
5217 int parms_len = (int)(d-s);
5218 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5219 "Precedence problem: open %.*s should be open(%.*s)",
5220 parms_len, s, parms_len, s);
5226 yylval.ival = OP_OR;
5236 LOP(OP_OPEN_DIR,XTERM);
5239 checkcomma(s,PL_tokenbuf,"filehandle");
5243 checkcomma(s,PL_tokenbuf,"filehandle");
5262 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5266 LOP(OP_PIPE_OP,XTERM);
5269 s = scan_str(s,FALSE,FALSE);
5271 missingterm((char*)0);
5272 yylval.ival = OP_CONST;
5273 TERM(sublex_start());
5279 s = scan_str(s,FALSE,FALSE);
5281 missingterm((char*)0);
5282 PL_expect = XOPERATOR;
5284 if (SvCUR(PL_lex_stuff)) {
5287 d = SvPV_force(PL_lex_stuff, len);
5290 for (; isSPACE(*d) && len; --len, ++d) ;
5293 if (!warned && ckWARN(WARN_QW)) {
5294 for (; !isSPACE(*d) && len; --len, ++d) {
5296 Perl_warner(aTHX_ packWARN(WARN_QW),
5297 "Possible attempt to separate words with commas");
5300 else if (*d == '#') {
5301 Perl_warner(aTHX_ packWARN(WARN_QW),
5302 "Possible attempt to put comments in qw() list");
5308 for (; !isSPACE(*d) && len; --len, ++d) ;
5310 sv = newSVpvn(b, d-b);
5311 if (DO_UTF8(PL_lex_stuff))
5313 words = append_elem(OP_LIST, words,
5314 newSVOP(OP_CONST, 0, tokeq(sv)));
5318 NEXTVAL_NEXTTOKE.opval = words;
5323 SvREFCNT_dec(PL_lex_stuff);
5324 PL_lex_stuff = NULL;
5330 s = scan_str(s,FALSE,FALSE);
5332 missingterm((char*)0);
5333 yylval.ival = OP_STRINGIFY;
5334 if (SvIVX(PL_lex_stuff) == '\'')
5335 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
5336 TERM(sublex_start());
5339 s = scan_pat(s,OP_QR);
5340 TERM(sublex_start());
5343 s = scan_str(s,FALSE,FALSE);
5345 missingterm((char*)0);
5346 yylval.ival = OP_BACKTICK;
5348 TERM(sublex_start());
5356 s = force_version(s, FALSE);
5358 else if (*s != 'v' || !isDIGIT(s[1])
5359 || (s = force_version(s, TRUE), *s == 'v'))
5361 *PL_tokenbuf = '\0';
5362 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5363 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5364 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5366 yyerror("<> should be quotes");
5368 if (orig_keyword == KEY_require) {
5376 PL_last_uni = PL_oldbufptr;
5377 PL_last_lop_op = OP_REQUIRE;
5379 return REPORT( (int)REQUIRE );
5385 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5389 LOP(OP_RENAME,XTERM);
5398 LOP(OP_RINDEX,XTERM);
5408 UNIDOR(OP_READLINE);
5421 LOP(OP_REVERSE,XTERM);
5424 UNIDOR(OP_READLINK);
5432 TERM(sublex_start());
5434 TOKEN(1); /* force error */
5437 checkcomma(s,PL_tokenbuf,"filehandle");
5447 LOP(OP_SELECT,XTERM);
5453 LOP(OP_SEMCTL,XTERM);
5456 LOP(OP_SEMGET,XTERM);
5459 LOP(OP_SEMOP,XTERM);
5465 LOP(OP_SETPGRP,XTERM);
5467 case KEY_setpriority:
5468 LOP(OP_SETPRIORITY,XTERM);
5470 case KEY_sethostent:
5476 case KEY_setservent:
5479 case KEY_setprotoent:
5489 LOP(OP_SEEKDIR,XTERM);
5491 case KEY_setsockopt:
5492 LOP(OP_SSOCKOPT,XTERM);
5498 LOP(OP_SHMCTL,XTERM);
5501 LOP(OP_SHMGET,XTERM);
5504 LOP(OP_SHMREAD,XTERM);
5507 LOP(OP_SHMWRITE,XTERM);
5510 LOP(OP_SHUTDOWN,XTERM);
5519 LOP(OP_SOCKET,XTERM);
5521 case KEY_socketpair:
5522 LOP(OP_SOCKPAIR,XTERM);
5525 checkcomma(s,PL_tokenbuf,"subroutine name");
5527 if (*s == ';' || *s == ')') /* probably a close */
5528 Perl_croak(aTHX_ "sort is now a reserved word");
5530 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5534 LOP(OP_SPLIT,XTERM);
5537 LOP(OP_SPRINTF,XTERM);
5540 LOP(OP_SPLICE,XTERM);
5555 LOP(OP_SUBSTR,XTERM);
5561 char tmpbuf[sizeof PL_tokenbuf];
5562 SSize_t tboffset = 0;
5563 expectation attrful;
5564 bool have_name, have_proto, bad_proto;
5565 const int key = tmp;
5569 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5570 (*s == ':' && s[1] == ':'))
5573 attrful = XATTRBLOCK;
5574 /* remember buffer pos'n for later force_word */
5575 tboffset = s - PL_oldbufptr;
5576 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5577 if (strchr(tmpbuf, ':'))
5578 sv_setpv(PL_subname, tmpbuf);
5580 sv_setsv(PL_subname,PL_curstname);
5581 sv_catpvs(PL_subname,"::");
5582 sv_catpvn(PL_subname,tmpbuf,len);
5589 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5590 PL_expect = XTERMBLOCK;
5591 attrful = XATTRTERM;
5592 sv_setpvn(PL_subname,"?",1);
5596 if (key == KEY_format) {
5598 PL_lex_formbrack = PL_lex_brackets + 1;
5600 (void) force_word(PL_oldbufptr + tboffset, WORD,
5605 /* Look for a prototype */
5609 s = scan_str(s,FALSE,FALSE);
5611 Perl_croak(aTHX_ "Prototype not terminated");
5612 /* strip spaces and check for bad characters */
5613 d = SvPVX(PL_lex_stuff);
5616 for (p = d; *p; ++p) {
5619 if (!strchr("$@%*;[]&\\", *p))
5624 if (bad_proto && ckWARN(WARN_SYNTAX))
5625 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5626 "Illegal character in prototype for %"SVf" : %s",
5628 SvCUR_set(PL_lex_stuff, tmp);
5636 if (*s == ':' && s[1] != ':')
5637 PL_expect = attrful;
5638 else if (*s != '{' && key == KEY_sub) {
5640 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5642 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5646 NEXTVAL_NEXTTOKE.opval =
5647 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5648 PL_lex_stuff = NULL;
5652 sv_setpv(PL_subname,
5653 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5656 (void) force_word(PL_oldbufptr + tboffset, WORD,
5665 LOP(OP_SYSTEM,XREF);
5668 LOP(OP_SYMLINK,XTERM);
5671 LOP(OP_SYSCALL,XTERM);
5674 LOP(OP_SYSOPEN,XTERM);
5677 LOP(OP_SYSSEEK,XTERM);
5680 LOP(OP_SYSREAD,XTERM);
5683 LOP(OP_SYSWRITE,XTERM);
5687 TERM(sublex_start());
5708 LOP(OP_TRUNCATE,XTERM);
5720 yylval.ival = CopLINE(PL_curcop);
5724 yylval.ival = CopLINE(PL_curcop);
5728 LOP(OP_UNLINK,XTERM);
5734 LOP(OP_UNPACK,XTERM);
5737 LOP(OP_UTIME,XTERM);
5743 LOP(OP_UNSHIFT,XTERM);
5746 s = tokenize_use(1, s);
5756 yylval.ival = CopLINE(PL_curcop);
5760 yylval.ival = CopLINE(PL_curcop);
5764 PL_hints |= HINT_BLOCK_SCOPE;
5771 LOP(OP_WAITPID,XTERM);
5780 ctl_l[0] = toCTRL('L');
5782 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
5785 /* Make sure $^L is defined */
5786 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
5791 if (PL_expect == XOPERATOR)
5797 yylval.ival = OP_XOR;
5802 TERM(sublex_start());
5807 #pragma segment Main
5811 S_pending_ident(pTHX)
5815 register I32 tmp = 0;
5816 /* pit holds the identifier we read and pending_ident is reset */
5817 char pit = PL_pending_ident;
5818 PL_pending_ident = 0;
5820 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5821 "### Pending identifier '%s'\n", PL_tokenbuf); });
5823 /* if we're in a my(), we can't allow dynamics here.
5824 $foo'bar has already been turned into $foo::bar, so
5825 just check for colons.
5827 if it's a legal name, the OP is a PADANY.
5830 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5831 if (strchr(PL_tokenbuf,':'))
5832 yyerror(Perl_form(aTHX_ "No package name allowed for "
5833 "variable %s in \"our\"",
5835 tmp = allocmy(PL_tokenbuf);
5838 if (strchr(PL_tokenbuf,':'))
5839 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5841 yylval.opval = newOP(OP_PADANY, 0);
5842 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5848 build the ops for accesses to a my() variable.
5850 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5851 then used in a comparison. This catches most, but not
5852 all cases. For instance, it catches
5853 sort { my($a); $a <=> $b }
5855 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5856 (although why you'd do that is anyone's guess).
5859 if (!strchr(PL_tokenbuf,':')) {
5861 tmp = pad_findmy(PL_tokenbuf);
5862 if (tmp != NOT_IN_PAD) {
5863 /* might be an "our" variable" */
5864 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
5865 /* build ops for a bareword */
5866 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
5867 HEK * const stashname = HvNAME_HEK(stash);
5868 SV * const sym = newSVhek(stashname);
5869 sv_catpvs(sym, "::");
5870 sv_catpv(sym, PL_tokenbuf+1);
5871 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5872 yylval.opval->op_private = OPpCONST_ENTERED;
5875 ? (GV_ADDMULTI | GV_ADDINEVAL)
5878 ((PL_tokenbuf[0] == '$') ? SVt_PV
5879 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5884 /* if it's a sort block and they're naming $a or $b */
5885 if (PL_last_lop_op == OP_SORT &&
5886 PL_tokenbuf[0] == '$' &&
5887 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5890 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5891 d < PL_bufend && *d != '\n';
5894 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5895 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5901 yylval.opval = newOP(OP_PADANY, 0);
5902 yylval.opval->op_targ = tmp;
5908 Whine if they've said @foo in a doublequoted string,
5909 and @foo isn't a variable we can find in the symbol
5912 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5913 GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
5914 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5915 && ckWARN(WARN_AMBIGUOUS))
5917 /* Downgraded from fatal to warning 20000522 mjd */
5918 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5919 "Possible unintended interpolation of %s in string",
5924 /* build ops for a bareword */
5925 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5926 yylval.opval->op_private = OPpCONST_ENTERED;
5929 /* If the identifier refers to a stash, don't autovivify it.
5930 * Change 24660 had the side effect of causing symbol table
5931 * hashes to always be defined, even if they were freshly
5932 * created and the only reference in the entire program was
5933 * the single statement with the defined %foo::bar:: test.
5934 * It appears that all code in the wild doing this actually
5935 * wants to know whether sub-packages have been loaded, so
5936 * by avoiding auto-vivifying symbol tables, we ensure that
5937 * defined %foo::bar:: continues to be false, and the existing
5938 * tests still give the expected answers, even though what
5939 * they're actually testing has now changed subtly.
5941 (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
5943 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
5944 ((PL_tokenbuf[0] == '$') ? SVt_PV
5945 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5951 * The following code was generated by perl_keyword.pl.
5955 Perl_keyword (pTHX_ const char *name, I32 len)
5960 case 1: /* 5 tokens of length 1 */
5992 case 2: /* 18 tokens of length 2 */
6138 case 3: /* 29 tokens of length 3 */
6142 if (name[1] == 'N' &&
6205 if (name[1] == 'i' &&
6227 return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
6245 if (name[1] == 'o' &&
6254 if (name[1] == 'e' &&
6263 if (name[1] == 'n' &&
6272 if (name[1] == 'o' &&
6281 if (name[1] == 'a' &&
6290 if (name[1] == 'o' &&
6352 if (name[1] == 'e' &&
6366 return (FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
6392 if (name[1] == 'i' &&
6401 if (name[1] == 's' &&
6410 if (name[1] == 'e' &&
6419 if (name[1] == 'o' &&
6431 case 4: /* 41 tokens of length 4 */
6435 if (name[1] == 'O' &&
6445 if (name[1] == 'N' &&
6455 if (name[1] == 'i' &&
6465 if (name[1] == 'h' &&
6475 if (name[1] == 'u' &&
6488 if (name[2] == 'c' &&
6497 if (name[2] == 's' &&
6506 if (name[2] == 'a' &&
6542 if (name[1] == 'o' &&
6555 if (name[2] == 't' &&
6564 if (name[2] == 'o' &&
6573 if (name[2] == 't' &&
6582 if (name[2] == 'e' &&
6595 if (name[1] == 'o' &&
6608 if (name[2] == 'y' &&
6617 if (name[2] == 'l' &&
6633 if (name[2] == 's' &&
6642 if (name[2] == 'n' &&
6651 if (name[2] == 'c' &&
6664 if (name[1] == 'e' &&
6674 if (name[1] == 'p' &&
6687 if (name[2] == 'c' &&
6696 if (name[2] == 'p' &&
6705 if (name[2] == 's' &&
6721 if (name[2] == 'n' &&
6791 if (name[2] == 'r' &&
6800 if (name[2] == 'r' &&
6809 if (name[2] == 'a' &&
6825 if (name[2] == 'l' &&
6887 if (name[2] == 'e' &&
6890 return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
6903 case 5: /* 38 tokens of length 5 */
6907 if (name[1] == 'E' &&
6918 if (name[1] == 'H' &&
6932 if (name[2] == 'a' &&
6942 if (name[2] == 'a' &&
6959 if (name[2] == 'e' &&
6969 if (name[2] == 'e' &&
6973 return (FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
6989 if (name[3] == 'i' &&
6998 if (name[3] == 'o' &&
7034 if (name[2] == 'o' &&
7044 if (name[2] == 'y' &&
7058 if (name[1] == 'l' &&
7072 if (name[2] == 'n' &&
7082 if (name[2] == 'o' &&
7096 if (name[1] == 'i' &&
7101 return (FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
7110 if (name[2] == 'd' &&
7120 if (name[2] == 'c' &&
7137 if (name[2] == 'c' &&
7147 if (name[2] == 't' &&
7161 if (name[1] == 'k' &&
7172 if (name[1] == 'r' &&
7186 if (name[2] == 's' &&
7196 if (name[2] == 'd' &&
7213 if (name[2] == 'm' &&
7223 if (name[2] == 'i' &&
7233 if (name[2] == 'e' &&
7243 if (name[2] == 'l' &&
7253 if (name[2] == 'a' &&
7263 if (name[2] == 'u' &&
7277 if (name[1] == 'i' &&
7291 if (name[2] == 'a' &&
7304 if (name[3] == 'e' &&
7339 if (name[2] == 'i' &&
7356 if (name[2] == 'i' &&
7366 if (name[2] == 'i' &&
7383 case 6: /* 33 tokens of length 6 */
7387 if (name[1] == 'c' &&
7402 if (name[2] == 'l' &&
7413 if (name[2] == 'r' &&
7428 if (name[1] == 'e' &&
7443 if (name[2] == 's' &&
7448 if(ckWARN_d(WARN_SYNTAX))
7449 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7455 if (name[2] == 'i' &&
7473 if (name[2] == 'l' &&
7484 if (name[2] == 'r' &&
7499 if (name[1] == 'm' &&
7514 if (name[2] == 'n' &&
7525 if (name[2] == 's' &&
7540 if (name[1] == 's' &&
7546 if (name[4] == 't' &&
7555 if (name[4] == 'e' &&
7564 if (name[4] == 'c' &&
7573 if (name[4] == 'n' &&
7589 if (name[1] == 'r' &&
7607 if (name[3] == 'a' &&
7617 if (name[3] == 'u' &&
7631 if (name[2] == 'n' &&
7649 if (name[2] == 'a' &&
7663 if (name[3] == 'e' &&
7676 if (name[4] == 't' &&
7685 if (name[4] == 'e' &&
7707 if (name[4] == 't' &&
7716 if (name[4] == 'e' &&
7732 if (name[2] == 'c' &&
7743 if (name[2] == 'l' &&
7754 if (name[2] == 'b' &&
7765 if (name[2] == 's' &&
7788 if (name[4] == 's' &&
7797 if (name[4] == 'n' &&
7810 if (name[3] == 'a' &&
7827 if (name[1] == 'a' &&
7842 case 7: /* 29 tokens of length 7 */
7846 if (name[1] == 'E' &&
7859 if (name[1] == '_' &&
7872 if (name[1] == 'i' &&
7879 return -KEY_binmode;
7885 if (name[1] == 'o' &&
7892 return -KEY_connect;
7901 if (name[2] == 'm' &&
7907 return -KEY_dbmopen;
7918 if (name[4] == 'u' &&
7922 return (FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
7928 if (name[4] == 'n' &&
7949 if (name[1] == 'o' &&
7962 if (name[1] == 'e' &&
7969 if (name[5] == 'r' &&
7972 return -KEY_getpgrp;
7978 if (name[5] == 'i' &&
7981 return -KEY_getppid;
7994 if (name[1] == 'c' &&
8001 return -KEY_lcfirst;
8007 if (name[1] == 'p' &&
8014 return -KEY_opendir;
8020 if (name[1] == 'a' &&
8038 if (name[3] == 'd' &&
8043 return -KEY_readdir;
8049 if (name[3] == 'u' &&
8060 if (name[3] == 'e' &&
8065 return -KEY_reverse;
8084 if (name[3] == 'k' &&
8089 return -KEY_seekdir;
8095 if (name[3] == 'p' &&
8100 return -KEY_setpgrp;
8110 if (name[2] == 'm' &&
8116 return -KEY_shmread;
8122 if (name[2] == 'r' &&
8128 return -KEY_sprintf;
8137 if (name[3] == 'l' &&
8142 return -KEY_symlink;
8151 if (name[4] == 'a' &&
8155 return -KEY_syscall;
8161 if (name[4] == 'p' &&
8165 return -KEY_sysopen;
8171 if (name[4] == 'e' &&
8175 return -KEY_sysread;
8181 if (name[4] == 'e' &&
8185 return -KEY_sysseek;
8203 if (name[1] == 'e' &&
8210 return -KEY_telldir;
8219 if (name[2] == 'f' &&
8225 return -KEY_ucfirst;
8231 if (name[2] == 's' &&
8237 return -KEY_unshift;
8247 if (name[1] == 'a' &&
8254 return -KEY_waitpid;
8263 case 8: /* 26 tokens of length 8 */
8267 if (name[1] == 'U' &&
8275 return KEY_AUTOLOAD;
8286 if (name[3] == 'A' &&
8292 return KEY___DATA__;
8298 if (name[3] == 'I' &&
8304 return -KEY___FILE__;
8310 if (name[3] == 'I' &&
8316 return -KEY___LINE__;
8332 if (name[2] == 'o' &&
8339 return -KEY_closedir;
8345 if (name[2] == 'n' &&
8352 return -KEY_continue;
8362 if (name[1] == 'b' &&
8370 return -KEY_dbmclose;
8376 if (name[1] == 'n' &&
8382 if (name[4] == 'r' &&
8387 return -KEY_endgrent;
8393 if (name[4] == 'w' &&
8398 return -KEY_endpwent;
8411 if (name[1] == 'o' &&
8419 return -KEY_formline;
8425 if (name[1] == 'e' &&
8436 if (name[6] == 'n' &&
8439 return -KEY_getgrent;
8445 if (name[6] == 'i' &&
8448 return -KEY_getgrgid;
8454 if (name[6] == 'a' &&
8457 return -KEY_getgrnam;
8470 if (name[4] == 'o' &&
8475 return -KEY_getlogin;
8486 if (name[6] == 'n' &&
8489 return -KEY_getpwent;
8495 if (name[6] == 'a' &&
8498 return -KEY_getpwnam;
8504 if (name[6] == 'i' &&
8507 return -KEY_getpwuid;
8527 if (name[1] == 'e' &&
8534 if (name[5] == 'i' &&
8541 return -KEY_readline;
8546 return -KEY_readlink;
8557 if (name[5] == 'i' &&
8561 return -KEY_readpipe;
8582 if (name[4] == 'r' &&
8587 return -KEY_setgrent;
8593 if (name[4] == 'w' &&
8598 return -KEY_setpwent;
8614 if (name[3] == 'w' &&
8620 return -KEY_shmwrite;
8626 if (name[3] == 't' &&
8632 return -KEY_shutdown;
8642 if (name[2] == 's' &&
8649 return -KEY_syswrite;
8659 if (name[1] == 'r' &&
8667 return -KEY_truncate;
8676 case 9: /* 8 tokens of length 9 */
8680 if (name[1] == 'n' &&
8689 return -KEY_endnetent;
8695 if (name[1] == 'e' &&
8704 return -KEY_getnetent;
8710 if (name[1] == 'o' &&
8719 return -KEY_localtime;
8725 if (name[1] == 'r' &&
8734 return KEY_prototype;
8740 if (name[1] == 'u' &&
8749 return -KEY_quotemeta;
8755 if (name[1] == 'e' &&
8764 return -KEY_rewinddir;
8770 if (name[1] == 'e' &&
8779 return -KEY_setnetent;
8785 if (name[1] == 'a' &&
8794 return -KEY_wantarray;
8803 case 10: /* 9 tokens of length 10 */
8807 if (name[1] == 'n' &&
8813 if (name[4] == 'o' &&
8820 return -KEY_endhostent;
8826 if (name[4] == 'e' &&
8833 return -KEY_endservent;
8846 if (name[1] == 'e' &&
8852 if (name[4] == 'o' &&
8859 return -KEY_gethostent;
8868 if (name[5] == 'r' &&
8874 return -KEY_getservent;
8880 if (name[5] == 'c' &&
8886 return -KEY_getsockopt;
8911 if (name[4] == 'o' &&
8918 return -KEY_sethostent;
8927 if (name[5] == 'r' &&
8933 return -KEY_setservent;
8939 if (name[5] == 'c' &&
8945 return -KEY_setsockopt;
8962 if (name[2] == 'c' &&
8971 return -KEY_socketpair;
8984 case 11: /* 8 tokens of length 11 */
8988 if (name[1] == '_' &&
8999 return -KEY___PACKAGE__;
9005 if (name[1] == 'n' &&
9016 return -KEY_endprotoent;
9022 if (name[1] == 'e' &&
9031 if (name[5] == 'e' &&
9038 return -KEY_getpeername;
9047 if (name[6] == 'o' &&
9053 return -KEY_getpriority;
9059 if (name[6] == 't' &&
9065 return -KEY_getprotoent;
9079 if (name[4] == 'o' &&
9087 return -KEY_getsockname;
9100 if (name[1] == 'e' &&
9108 if (name[6] == 'o' &&
9114 return -KEY_setpriority;
9120 if (name[6] == 't' &&
9126 return -KEY_setprotoent;
9142 case 12: /* 2 tokens of length 12 */
9143 if (name[0] == 'g' &&
9155 if (name[9] == 'd' &&
9158 { /* getnetbyaddr */
9159 return -KEY_getnetbyaddr;
9165 if (name[9] == 'a' &&
9168 { /* getnetbyname */
9169 return -KEY_getnetbyname;
9181 case 13: /* 4 tokens of length 13 */
9182 if (name[0] == 'g' &&
9189 if (name[4] == 'o' &&
9198 if (name[10] == 'd' &&
9201 { /* gethostbyaddr */
9202 return -KEY_gethostbyaddr;
9208 if (name[10] == 'a' &&
9211 { /* gethostbyname */
9212 return -KEY_gethostbyname;
9225 if (name[4] == 'e' &&
9234 if (name[10] == 'a' &&
9237 { /* getservbyname */
9238 return -KEY_getservbyname;
9244 if (name[10] == 'o' &&
9247 { /* getservbyport */
9248 return -KEY_getservbyport;
9267 case 14: /* 1 tokens of length 14 */
9268 if (name[0] == 'g' &&
9282 { /* getprotobyname */
9283 return -KEY_getprotobyname;
9288 case 16: /* 1 tokens of length 16 */
9289 if (name[0] == 'g' &&
9305 { /* getprotobynumber */
9306 return -KEY_getprotobynumber;
9320 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
9325 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9326 if (ckWARN(WARN_SYNTAX)) {
9328 for (w = s+2; *w && level; w++) {
9335 for (; *w && isSPACE(*w); w++) ;
9336 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
9337 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9338 "%s (...) interpreted as function",name);
9341 while (s < PL_bufend && isSPACE(*s))
9345 while (s < PL_bufend && isSPACE(*s))
9347 if (isIDFIRST_lazy_if(s,UTF)) {
9349 while (isALNUM_lazy_if(s,UTF))
9351 while (s < PL_bufend && isSPACE(*s))
9355 *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
9356 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
9360 Perl_croak(aTHX_ "No comma allowed after %s", what);
9365 /* Either returns sv, or mortalizes sv and returns a new SV*.
9366 Best used as sv=new_constant(..., sv, ...).
9367 If s, pv are NULL, calls subroutine with one argument,
9368 and type is used with error messages only. */
9371 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9375 HV * const table = GvHV(PL_hintgv); /* ^H */
9379 const char *why1 = "", *why2 = "", *why3 = "";
9381 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9384 why2 = strEQ(key,"charnames")
9385 ? "(possibly a missing \"use charnames ...\")"
9387 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9388 (type ? type: "undef"), why2);
9390 /* This is convoluted and evil ("goto considered harmful")
9391 * but I do not understand the intricacies of all the different
9392 * failure modes of %^H in here. The goal here is to make
9393 * the most probable error message user-friendly. --jhi */
9398 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9399 (type ? type: "undef"), why1, why2, why3);
9401 yyerror(SvPVX_const(msg));
9405 cvp = hv_fetch(table, key, strlen(key), FALSE);
9406 if (!cvp || !SvOK(*cvp)) {
9409 why3 = "} is not defined";
9412 sv_2mortal(sv); /* Parent created it permanently */
9415 pv = sv_2mortal(newSVpvn(s, len));
9417 typesv = sv_2mortal(newSVpv(type, 0));
9419 typesv = &PL_sv_undef;
9421 PUSHSTACKi(PERLSI_OVERLOAD);
9433 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9437 /* Check the eval first */
9438 if (!PL_in_eval && SvTRUE(ERRSV)) {
9439 sv_catpvs(ERRSV, "Propagated");
9440 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9442 res = SvREFCNT_inc_simple(sv);
9446 SvREFCNT_inc_simple_void(res);
9455 why1 = "Call to &{$^H{";
9457 why3 = "}} did not return a defined value";
9465 /* Returns a NUL terminated string, with the length of the string written to
9469 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9472 register char *d = dest;
9473 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
9476 Perl_croak(aTHX_ ident_too_long);
9477 if (isALNUM(*s)) /* UTF handled below */
9479 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9484 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9488 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9489 char *t = s + UTF8SKIP(s);
9490 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9492 if (d + (t - s) > e)
9493 Perl_croak(aTHX_ ident_too_long);
9494 Copy(s, d, t - s, char);
9507 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9510 char *bracket = NULL;
9512 register char *d = dest;
9513 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
9518 while (isDIGIT(*s)) {
9520 Perl_croak(aTHX_ ident_too_long);
9527 Perl_croak(aTHX_ ident_too_long);
9528 if (isALNUM(*s)) /* UTF handled below */
9530 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9535 else if (*s == ':' && s[1] == ':') {
9539 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9540 char *t = s + UTF8SKIP(s);
9541 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9543 if (d + (t - s) > e)
9544 Perl_croak(aTHX_ ident_too_long);
9545 Copy(s, d, t - s, char);
9556 if (PL_lex_state != LEX_NORMAL)
9557 PL_lex_state = LEX_INTERPENDMAYBE;
9560 if (*s == '$' && s[1] &&
9561 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9574 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9579 if (isSPACE(s[-1])) {
9581 const char ch = *s++;
9582 if (!SPACE_OR_TAB(ch)) {
9588 if (isIDFIRST_lazy_if(d,UTF)) {
9592 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
9593 end += UTF8SKIP(end);
9594 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
9595 end += UTF8SKIP(end);
9597 Copy(s, d, end - s, char);
9602 while ((isALNUM(*s) || *s == ':') && d < e)
9605 Perl_croak(aTHX_ ident_too_long);
9608 while (s < send && SPACE_OR_TAB(*s)) s++;
9609 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9610 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9611 const char *brack = *s == '[' ? "[...]" : "{...}";
9612 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9613 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9614 funny, dest, brack, funny, dest, brack);
9617 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9621 /* Handle extended ${^Foo} variables
9622 * 1999-02-27 mjd-perl-patch@plover.com */
9623 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9627 while (isALNUM(*s) && d < e) {
9631 Perl_croak(aTHX_ ident_too_long);
9636 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9637 PL_lex_state = LEX_INTERPEND;
9642 if (PL_lex_state == LEX_NORMAL) {
9643 if (ckWARN(WARN_AMBIGUOUS) &&
9644 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9646 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9647 "Ambiguous use of %c{%s} resolved to %c%s",
9648 funny, dest, funny, dest);
9653 s = bracket; /* let the parser handle it */
9657 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9658 PL_lex_state = LEX_INTERPEND;
9663 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9665 PERL_UNUSED_CONTEXT;
9669 *pmfl |= PMf_GLOBAL;
9671 *pmfl |= PMf_CONTINUE;
9675 *pmfl |= PMf_MULTILINE;
9677 *pmfl |= PMf_SINGLELINE;
9679 *pmfl |= PMf_EXTENDED;
9683 S_scan_pat(pTHX_ char *start, I32 type)
9687 char *s = scan_str(start,FALSE,FALSE);
9688 const char * const valid_flags = (type == OP_QR) ? "iomsx" : "iogcmsx";
9691 const char * const delimiter = skipspace(start);
9692 Perl_croak(aTHX_ *delimiter == '?'
9693 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9694 : "Search pattern not terminated" );
9697 pm = (PMOP*)newPMOP(type, 0);
9698 if (PL_multi_open == '?')
9699 pm->op_pmflags |= PMf_ONCE;
9700 while (*s && strchr(valid_flags, *s))
9701 pmflag(&pm->op_pmflags,*s++);
9702 /* issue a warning if /c is specified,but /g is not */
9703 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9704 && ckWARN(WARN_REGEXP))
9706 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
9709 pm->op_pmpermflags = pm->op_pmflags;
9711 PL_lex_op = (OP*)pm;
9712 yylval.ival = OP_MATCH;
9717 S_scan_subst(pTHX_ char *start)
9725 yylval.ival = OP_NULL;
9727 s = scan_str(start,FALSE,FALSE);
9730 Perl_croak(aTHX_ "Substitution pattern not terminated");
9732 if (s[-1] == PL_multi_open)
9735 first_start = PL_multi_start;
9736 s = scan_str(s,FALSE,FALSE);
9739 SvREFCNT_dec(PL_lex_stuff);
9740 PL_lex_stuff = NULL;
9742 Perl_croak(aTHX_ "Substitution replacement not terminated");
9744 PL_multi_start = first_start; /* so whole substitution is taken together */
9746 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9752 else if (strchr("iogcmsx", *s))
9753 pmflag(&pm->op_pmflags,*s++);
9758 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
9759 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9763 SV * const repl = newSVpvs("");
9765 PL_sublex_info.super_bufptr = s;
9766 PL_sublex_info.super_bufend = PL_bufend;
9768 pm->op_pmflags |= PMf_EVAL;
9770 sv_catpv(repl, es ? "eval " : "do ");
9771 sv_catpvs(repl, "{ ");
9772 sv_catsv(repl, PL_lex_repl);
9773 sv_catpvs(repl, " }");
9775 SvREFCNT_dec(PL_lex_repl);
9779 pm->op_pmpermflags = pm->op_pmflags;
9780 PL_lex_op = (OP*)pm;
9781 yylval.ival = OP_SUBST;
9786 S_scan_trans(pTHX_ char *start)
9796 yylval.ival = OP_NULL;
9798 s = scan_str(start,FALSE,FALSE);
9800 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9801 if (s[-1] == PL_multi_open)
9804 s = scan_str(s,FALSE,FALSE);
9807 SvREFCNT_dec(PL_lex_stuff);
9808 PL_lex_stuff = NULL;
9810 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9813 complement = del = squash = 0;
9817 complement = OPpTRANS_COMPLEMENT;
9820 del = OPpTRANS_DELETE;
9823 squash = OPpTRANS_SQUASH;
9832 Newx(tbl, complement&&!del?258:256, short);
9833 o = newPVOP(OP_TRANS, 0, (char*)tbl);
9834 o->op_private &= ~OPpTRANS_ALL;
9835 o->op_private |= del|squash|complement|
9836 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9837 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9840 yylval.ival = OP_TRANS;
9845 S_scan_heredoc(pTHX_ register char *s)
9849 I32 op_type = OP_SCALAR;
9853 const char *found_newline;
9857 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9861 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9864 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9865 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9868 s = delimcpy(d, e, s, PL_bufend, term, &len);
9878 if (!isALNUM_lazy_if(s,UTF))
9879 deprecate_old("bare << to mean <<\"\"");
9880 for (; isALNUM_lazy_if(s,UTF); s++) {
9885 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9886 Perl_croak(aTHX_ "Delimiter for here document is too long");
9889 len = d - PL_tokenbuf;
9890 #ifndef PERL_STRICT_CR
9891 d = strchr(s, '\r');
9893 char * const olds = s;
9895 while (s < PL_bufend) {
9901 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9910 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9914 if ( outer || !(found_newline = memchr(s, '\n', PL_bufend - s)) ) {
9915 herewas = newSVpvn(s,PL_bufend-s);
9919 herewas = newSVpvn(s,found_newline-s);
9921 s += SvCUR(herewas);
9924 sv_upgrade(tmpstr, SVt_PVIV);
9927 SvIV_set(tmpstr, -1);
9929 else if (term == '`') {
9930 op_type = OP_BACKTICK;
9931 SvIV_set(tmpstr, '\\');
9935 PL_multi_start = CopLINE(PL_curcop);
9936 PL_multi_open = PL_multi_close = '<';
9937 term = *PL_tokenbuf;
9938 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9939 char * const bufptr = PL_sublex_info.super_bufptr;
9940 char * const bufend = PL_sublex_info.super_bufend;
9941 char * const olds = s - SvCUR(herewas);
9942 s = strchr(bufptr, '\n');
9946 while (s < bufend &&
9947 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9949 CopLINE_inc(PL_curcop);
9952 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9953 missingterm(PL_tokenbuf);
9955 sv_setpvn(herewas,bufptr,d-bufptr+1);
9956 sv_setpvn(tmpstr,d+1,s-d);
9958 sv_catpvn(herewas,s,bufend-s);
9959 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9966 while (s < PL_bufend &&
9967 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9969 CopLINE_inc(PL_curcop);
9971 if (s >= PL_bufend) {
9972 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9973 missingterm(PL_tokenbuf);
9975 sv_setpvn(tmpstr,d+1,s-d);
9977 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9979 sv_catpvn(herewas,s,PL_bufend-s);
9980 sv_setsv(PL_linestr,herewas);
9981 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9982 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9983 PL_last_lop = PL_last_uni = NULL;
9986 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
9987 while (s >= PL_bufend) { /* multiple line string? */
9989 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9990 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9991 missingterm(PL_tokenbuf);
9993 CopLINE_inc(PL_curcop);
9994 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9995 PL_last_lop = PL_last_uni = NULL;
9996 #ifndef PERL_STRICT_CR
9997 if (PL_bufend - PL_linestart >= 2) {
9998 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9999 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10001 PL_bufend[-2] = '\n';
10003 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10005 else if (PL_bufend[-1] == '\r')
10006 PL_bufend[-1] = '\n';
10008 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10009 PL_bufend[-1] = '\n';
10011 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10012 SV * const sv = newSV(0);
10014 sv_upgrade(sv, SVt_PVMG);
10015 sv_setsv(sv,PL_linestr);
10016 (void)SvIOK_on(sv);
10018 av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv);
10020 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
10021 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
10022 *(SvPVX(PL_linestr) + off ) = ' ';
10023 sv_catsv(PL_linestr,herewas);
10024 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10025 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
10029 sv_catsv(tmpstr,PL_linestr);
10034 PL_multi_end = CopLINE(PL_curcop);
10035 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10036 SvPV_shrink_to_cur(tmpstr);
10038 SvREFCNT_dec(herewas);
10040 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10042 else if (PL_encoding)
10043 sv_recode_to_utf8(tmpstr, PL_encoding);
10045 PL_lex_stuff = tmpstr;
10046 yylval.ival = op_type;
10050 /* scan_inputsymbol
10051 takes: current position in input buffer
10052 returns: new position in input buffer
10053 side-effects: yylval and lex_op are set.
10058 <FH> read from filehandle
10059 <pkg::FH> read from package qualified filehandle
10060 <pkg'FH> read from package qualified filehandle
10061 <$fh> read from filehandle in $fh
10062 <*.h> filename glob
10067 S_scan_inputsymbol(pTHX_ char *start)
10070 register char *s = start; /* current position in buffer */
10074 char *d = PL_tokenbuf; /* start of temp holding space */
10075 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10077 end = strchr(s, '\n');
10080 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10082 /* die if we didn't have space for the contents of the <>,
10083 or if it didn't end, or if we see a newline
10086 if (len >= sizeof PL_tokenbuf)
10087 Perl_croak(aTHX_ "Excessively long <> operator");
10089 Perl_croak(aTHX_ "Unterminated <> operator");
10094 Remember, only scalar variables are interpreted as filehandles by
10095 this code. Anything more complex (e.g., <$fh{$num}>) will be
10096 treated as a glob() call.
10097 This code makes use of the fact that except for the $ at the front,
10098 a scalar variable and a filehandle look the same.
10100 if (*d == '$' && d[1]) d++;
10102 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10103 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
10106 /* If we've tried to read what we allow filehandles to look like, and
10107 there's still text left, then it must be a glob() and not a getline.
10108 Use scan_str to pull out the stuff between the <> and treat it
10109 as nothing more than a string.
10112 if (d - PL_tokenbuf != len) {
10113 yylval.ival = OP_GLOB;
10115 s = scan_str(start,FALSE,FALSE);
10117 Perl_croak(aTHX_ "Glob not terminated");
10121 bool readline_overriden = FALSE;
10124 /* we're in a filehandle read situation */
10127 /* turn <> into <ARGV> */
10129 Copy("ARGV",d,5,char);
10131 /* Check whether readline() is overriden */
10132 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
10134 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
10136 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
10137 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
10138 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
10139 readline_overriden = TRUE;
10141 /* if <$fh>, create the ops to turn the variable into a
10147 /* try to find it in the pad for this block, otherwise find
10148 add symbol table ops
10150 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
10151 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10152 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10153 HEK * const stashname = HvNAME_HEK(stash);
10154 SV * const sym = sv_2mortal(newSVhek(stashname));
10155 sv_catpvs(sym, "::");
10156 sv_catpv(sym, d+1);
10161 OP * const o = newOP(OP_PADSV, 0);
10163 PL_lex_op = readline_overriden
10164 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10165 append_elem(OP_LIST, o,
10166 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10167 : (OP*)newUNOP(OP_READLINE, 0, o);
10176 ? (GV_ADDMULTI | GV_ADDINEVAL)
10179 PL_lex_op = readline_overriden
10180 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10181 append_elem(OP_LIST,
10182 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10183 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10184 : (OP*)newUNOP(OP_READLINE, 0,
10185 newUNOP(OP_RV2SV, 0,
10186 newGVOP(OP_GV, 0, gv)));
10188 if (!readline_overriden)
10189 PL_lex_op->op_flags |= OPf_SPECIAL;
10190 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
10191 yylval.ival = OP_NULL;
10194 /* If it's none of the above, it must be a literal filehandle
10195 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10197 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
10198 PL_lex_op = readline_overriden
10199 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10200 append_elem(OP_LIST,
10201 newGVOP(OP_GV, 0, gv),
10202 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10203 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
10204 yylval.ival = OP_NULL;
10213 takes: start position in buffer
10214 keep_quoted preserve \ on the embedded delimiter(s)
10215 keep_delims preserve the delimiters around the string
10216 returns: position to continue reading from buffer
10217 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10218 updates the read buffer.
10220 This subroutine pulls a string out of the input. It is called for:
10221 q single quotes q(literal text)
10222 ' single quotes 'literal text'
10223 qq double quotes qq(interpolate $here please)
10224 " double quotes "interpolate $here please"
10225 qx backticks qx(/bin/ls -l)
10226 ` backticks `/bin/ls -l`
10227 qw quote words @EXPORT_OK = qw( func() $spam )
10228 m// regexp match m/this/
10229 s/// regexp substitute s/this/that/
10230 tr/// string transliterate tr/this/that/
10231 y/// string transliterate y/this/that/
10232 ($*@) sub prototypes sub foo ($)
10233 (stuff) sub attr parameters sub foo : attr(stuff)
10234 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10236 In most of these cases (all but <>, patterns and transliterate)
10237 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10238 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10239 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10242 It skips whitespace before the string starts, and treats the first
10243 character as the delimiter. If the delimiter is one of ([{< then
10244 the corresponding "close" character )]}> is used as the closing
10245 delimiter. It allows quoting of delimiters, and if the string has
10246 balanced delimiters ([{<>}]) it allows nesting.
10248 On success, the SV with the resulting string is put into lex_stuff or,
10249 if that is already non-NULL, into lex_repl. The second case occurs only
10250 when parsing the RHS of the special constructs s/// and tr/// (y///).
10251 For convenience, the terminating delimiter character is stuffed into
10256 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
10259 SV *sv; /* scalar value: string */
10260 char *tmps; /* temp string, used for delimiter matching */
10261 register char *s = start; /* current position in the buffer */
10262 register char term; /* terminating character */
10263 register char *to; /* current position in the sv's data */
10264 I32 brackets = 1; /* bracket nesting level */
10265 bool has_utf8 = FALSE; /* is there any utf8 content? */
10266 I32 termcode; /* terminating char. code */
10267 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10268 STRLEN termlen; /* length of terminating string */
10269 char *last = NULL; /* last position for nesting bracket */
10271 /* skip space before the delimiter */
10276 /* mark where we are, in case we need to report errors */
10279 /* after skipping whitespace, the next character is the terminator */
10282 termcode = termstr[0] = term;
10286 termcode = utf8_to_uvchr((U8*)s, &termlen);
10287 Copy(s, termstr, termlen, U8);
10288 if (!UTF8_IS_INVARIANT(term))
10292 /* mark where we are */
10293 PL_multi_start = CopLINE(PL_curcop);
10294 PL_multi_open = term;
10296 /* find corresponding closing delimiter */
10297 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
10298 termcode = termstr[0] = term = tmps[5];
10300 PL_multi_close = term;
10302 /* create a new SV to hold the contents. 79 is the SV's initial length.
10303 What a random number. */
10305 sv_upgrade(sv, SVt_PVIV);
10306 SvIV_set(sv, termcode);
10307 (void)SvPOK_only(sv); /* validate pointer */
10309 /* move past delimiter and try to read a complete string */
10311 sv_catpvn(sv, s, termlen);
10314 if (PL_encoding && !UTF) {
10318 int offset = s - SvPVX_const(PL_linestr);
10319 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
10320 &offset, (char*)termstr, termlen);
10321 const char * const ns = SvPVX_const(PL_linestr) + offset;
10322 char * const svlast = SvEND(sv) - 1;
10324 for (; s < ns; s++) {
10325 if (*s == '\n' && !PL_rsfp)
10326 CopLINE_inc(PL_curcop);
10329 goto read_more_line;
10331 /* handle quoted delimiters */
10332 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10334 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10336 if ((svlast-1 - t) % 2) {
10337 if (!keep_quoted) {
10338 *(svlast-1) = term;
10340 SvCUR_set(sv, SvCUR(sv) - 1);
10345 if (PL_multi_open == PL_multi_close) {
10353 for (t = w = last; t < svlast; w++, t++) {
10354 /* At here, all closes are "was quoted" one,
10355 so we don't check PL_multi_close. */
10357 if (!keep_quoted && *(t+1) == PL_multi_open)
10362 else if (*t == PL_multi_open)
10370 SvCUR_set(sv, w - SvPVX_const(sv));
10373 if (--brackets <= 0)
10378 if (!keep_delims) {
10379 SvCUR_set(sv, SvCUR(sv) - 1);
10385 /* extend sv if need be */
10386 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10387 /* set 'to' to the next character in the sv's string */
10388 to = SvPVX(sv)+SvCUR(sv);
10390 /* if open delimiter is the close delimiter read unbridle */
10391 if (PL_multi_open == PL_multi_close) {
10392 for (; s < PL_bufend; s++,to++) {
10393 /* embedded newlines increment the current line number */
10394 if (*s == '\n' && !PL_rsfp)
10395 CopLINE_inc(PL_curcop);
10396 /* handle quoted delimiters */
10397 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10398 if (!keep_quoted && s[1] == term)
10400 /* any other quotes are simply copied straight through */
10404 /* terminate when run out of buffer (the for() condition), or
10405 have found the terminator */
10406 else if (*s == term) {
10409 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10412 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10418 /* if the terminator isn't the same as the start character (e.g.,
10419 matched brackets), we have to allow more in the quoting, and
10420 be prepared for nested brackets.
10423 /* read until we run out of string, or we find the terminator */
10424 for (; s < PL_bufend; s++,to++) {
10425 /* embedded newlines increment the line count */
10426 if (*s == '\n' && !PL_rsfp)
10427 CopLINE_inc(PL_curcop);
10428 /* backslashes can escape the open or closing characters */
10429 if (*s == '\\' && s+1 < PL_bufend) {
10430 if (!keep_quoted &&
10431 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10436 /* allow nested opens and closes */
10437 else if (*s == PL_multi_close && --brackets <= 0)
10439 else if (*s == PL_multi_open)
10441 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10446 /* terminate the copied string and update the sv's end-of-string */
10448 SvCUR_set(sv, to - SvPVX_const(sv));
10451 * this next chunk reads more into the buffer if we're not done yet
10455 break; /* handle case where we are done yet :-) */
10457 #ifndef PERL_STRICT_CR
10458 if (to - SvPVX_const(sv) >= 2) {
10459 if ((to[-2] == '\r' && to[-1] == '\n') ||
10460 (to[-2] == '\n' && to[-1] == '\r'))
10464 SvCUR_set(sv, to - SvPVX_const(sv));
10466 else if (to[-1] == '\r')
10469 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10474 /* if we're out of file, or a read fails, bail and reset the current
10475 line marker so we can report where the unterminated string began
10478 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10480 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10483 /* we read a line, so increment our line counter */
10484 CopLINE_inc(PL_curcop);
10486 /* update debugger info */
10487 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10488 SV * const line_sv = newSV(0);
10490 sv_upgrade(line_sv, SVt_PVMG);
10491 sv_setsv(line_sv,PL_linestr);
10492 (void)SvIOK_on(line_sv);
10493 SvIV_set(line_sv, 0);
10494 av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop), line_sv);
10497 /* having changed the buffer, we must update PL_bufend */
10498 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10499 PL_last_lop = PL_last_uni = NULL;
10502 /* at this point, we have successfully read the delimited string */
10504 if (!PL_encoding || UTF) {
10506 sv_catpvn(sv, s, termlen);
10509 if (has_utf8 || PL_encoding)
10512 PL_multi_end = CopLINE(PL_curcop);
10514 /* if we allocated too much space, give some back */
10515 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10516 SvLEN_set(sv, SvCUR(sv) + 1);
10517 SvPV_renew(sv, SvLEN(sv));
10520 /* decide whether this is the first or second quoted string we've read
10533 takes: pointer to position in buffer
10534 returns: pointer to new position in buffer
10535 side-effects: builds ops for the constant in yylval.op
10537 Read a number in any of the formats that Perl accepts:
10539 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10540 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10543 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10545 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10548 If it reads a number without a decimal point or an exponent, it will
10549 try converting the number to an integer and see if it can do so
10550 without loss of precision.
10554 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10557 register const char *s = start; /* current position in buffer */
10558 register char *d; /* destination in temp buffer */
10559 register char *e; /* end of temp buffer */
10560 NV nv; /* number read, as a double */
10561 SV *sv = NULL; /* place to put the converted number */
10562 bool floatit; /* boolean: int or float? */
10563 const char *lastub = NULL; /* position of last underbar */
10564 static char const number_too_long[] = "Number too long";
10566 /* We use the first character to decide what type of number this is */
10570 Perl_croak(aTHX_ "panic: scan_num");
10572 /* if it starts with a 0, it could be an octal number, a decimal in
10573 0.13 disguise, or a hexadecimal number, or a binary number. */
10577 u holds the "number so far"
10578 shift the power of 2 of the base
10579 (hex == 4, octal == 3, binary == 1)
10580 overflowed was the number more than we can hold?
10582 Shift is used when we add a digit. It also serves as an "are
10583 we in octal/hex/binary?" indicator to disallow hex characters
10584 when in octal mode.
10589 bool overflowed = FALSE;
10590 bool just_zero = TRUE; /* just plain 0 or binary number? */
10591 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10592 static const char* const bases[5] =
10593 { "", "binary", "", "octal", "hexadecimal" };
10594 static const char* const Bases[5] =
10595 { "", "Binary", "", "Octal", "Hexadecimal" };
10596 static const char* const maxima[5] =
10598 "0b11111111111111111111111111111111",
10602 const char *base, *Base, *max;
10604 /* check for hex */
10609 } else if (s[1] == 'b') {
10614 /* check for a decimal in disguise */
10615 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10617 /* so it must be octal */
10624 if (ckWARN(WARN_SYNTAX))
10625 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10626 "Misplaced _ in number");
10630 base = bases[shift];
10631 Base = Bases[shift];
10632 max = maxima[shift];
10634 /* read the rest of the number */
10636 /* x is used in the overflow test,
10637 b is the digit we're adding on. */
10642 /* if we don't mention it, we're done */
10646 /* _ are ignored -- but warned about if consecutive */
10648 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10649 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10650 "Misplaced _ in number");
10654 /* 8 and 9 are not octal */
10655 case '8': case '9':
10657 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10661 case '2': case '3': case '4':
10662 case '5': case '6': case '7':
10664 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10667 case '0': case '1':
10668 b = *s++ & 15; /* ASCII digit -> value of digit */
10672 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10673 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10674 /* make sure they said 0x */
10677 b = (*s++ & 7) + 9;
10679 /* Prepare to put the digit we have onto the end
10680 of the number so far. We check for overflows.
10686 x = u << shift; /* make room for the digit */
10688 if ((x >> shift) != u
10689 && !(PL_hints & HINT_NEW_BINARY)) {
10692 if (ckWARN_d(WARN_OVERFLOW))
10693 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10694 "Integer overflow in %s number",
10697 u = x | b; /* add the digit to the end */
10700 n *= nvshift[shift];
10701 /* If an NV has not enough bits in its
10702 * mantissa to represent an UV this summing of
10703 * small low-order numbers is a waste of time
10704 * (because the NV cannot preserve the
10705 * low-order bits anyway): we could just
10706 * remember when did we overflow and in the
10707 * end just multiply n by the right
10715 /* if we get here, we had success: make a scalar value from
10720 /* final misplaced underbar check */
10721 if (s[-1] == '_') {
10722 if (ckWARN(WARN_SYNTAX))
10723 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10728 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10729 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10730 "%s number > %s non-portable",
10736 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10737 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10738 "%s number > %s non-portable",
10743 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10744 sv = new_constant(start, s - start, "integer",
10746 else if (PL_hints & HINT_NEW_BINARY)
10747 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
10752 handle decimal numbers.
10753 we're also sent here when we read a 0 as the first digit
10755 case '1': case '2': case '3': case '4': case '5':
10756 case '6': case '7': case '8': case '9': case '.':
10759 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10762 /* read next group of digits and _ and copy into d */
10763 while (isDIGIT(*s) || *s == '_') {
10764 /* skip underscores, checking for misplaced ones
10768 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10769 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10770 "Misplaced _ in number");
10774 /* check for end of fixed-length buffer */
10776 Perl_croak(aTHX_ number_too_long);
10777 /* if we're ok, copy the character */
10782 /* final misplaced underbar check */
10783 if (lastub && s == lastub + 1) {
10784 if (ckWARN(WARN_SYNTAX))
10785 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10788 /* read a decimal portion if there is one. avoid
10789 3..5 being interpreted as the number 3. followed
10792 if (*s == '.' && s[1] != '.') {
10797 if (ckWARN(WARN_SYNTAX))
10798 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10799 "Misplaced _ in number");
10803 /* copy, ignoring underbars, until we run out of digits.
10805 for (; isDIGIT(*s) || *s == '_'; s++) {
10806 /* fixed length buffer check */
10808 Perl_croak(aTHX_ number_too_long);
10810 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10811 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10812 "Misplaced _ in number");
10818 /* fractional part ending in underbar? */
10819 if (s[-1] == '_') {
10820 if (ckWARN(WARN_SYNTAX))
10821 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10822 "Misplaced _ in number");
10824 if (*s == '.' && isDIGIT(s[1])) {
10825 /* oops, it's really a v-string, but without the "v" */
10831 /* read exponent part, if present */
10832 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10836 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10837 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10839 /* stray preinitial _ */
10841 if (ckWARN(WARN_SYNTAX))
10842 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10843 "Misplaced _ in number");
10847 /* allow positive or negative exponent */
10848 if (*s == '+' || *s == '-')
10851 /* stray initial _ */
10853 if (ckWARN(WARN_SYNTAX))
10854 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10855 "Misplaced _ in number");
10859 /* read digits of exponent */
10860 while (isDIGIT(*s) || *s == '_') {
10863 Perl_croak(aTHX_ number_too_long);
10867 if (((lastub && s == lastub + 1) ||
10868 (!isDIGIT(s[1]) && s[1] != '_'))
10869 && ckWARN(WARN_SYNTAX))
10870 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10871 "Misplaced _ in number");
10878 /* make an sv from the string */
10882 We try to do an integer conversion first if no characters
10883 indicating "float" have been found.
10888 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10890 if (flags == IS_NUMBER_IN_UV) {
10892 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10895 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10896 if (uv <= (UV) IV_MIN)
10897 sv_setiv(sv, -(IV)uv);
10904 /* terminate the string */
10906 nv = Atof(PL_tokenbuf);
10910 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10911 (PL_hints & HINT_NEW_INTEGER) )
10912 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10913 (floatit ? "float" : "integer"),
10917 /* if it starts with a v, it could be a v-string */
10920 sv = newSV(5); /* preallocate storage space */
10921 s = scan_vstring(s,sv);
10925 /* make the op for the constant and return */
10928 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10930 lvalp->opval = NULL;
10936 S_scan_formline(pTHX_ register char *s)
10939 register char *eol;
10941 SV * const stuff = newSVpvs("");
10942 bool needargs = FALSE;
10943 bool eofmt = FALSE;
10945 while (!needargs) {
10947 #ifdef PERL_STRICT_CR
10948 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10950 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10952 if (*t == '\n' || t == PL_bufend) {
10957 if (PL_in_eval && !PL_rsfp) {
10958 eol = (char *) memchr(s,'\n',PL_bufend-s);
10963 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10965 for (t = s; t < eol; t++) {
10966 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10968 goto enough; /* ~~ must be first line in formline */
10970 if (*t == '@' || *t == '^')
10974 sv_catpvn(stuff, s, eol-s);
10975 #ifndef PERL_STRICT_CR
10976 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10977 char *end = SvPVX(stuff) + SvCUR(stuff);
10980 SvCUR_set(stuff, SvCUR(stuff) - 1);
10989 s = filter_gets(PL_linestr, PL_rsfp, 0);
10990 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10991 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10992 PL_last_lop = PL_last_uni = NULL;
11001 if (SvCUR(stuff)) {
11004 PL_lex_state = LEX_NORMAL;
11005 NEXTVAL_NEXTTOKE.ival = 0;
11009 PL_lex_state = LEX_FORMLINE;
11011 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11013 else if (PL_encoding)
11014 sv_recode_to_utf8(stuff, PL_encoding);
11016 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
11018 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
11022 SvREFCNT_dec(stuff);
11024 PL_lex_formbrack = 0;
11036 PL_cshlen = strlen(PL_cshname);
11038 #if defined(USE_ITHREADS)
11039 PERL_UNUSED_CONTEXT;
11045 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11048 const I32 oldsavestack_ix = PL_savestack_ix;
11049 CV* const outsidecv = PL_compcv;
11052 assert(SvTYPE(PL_compcv) == SVt_PVCV);
11054 SAVEI32(PL_subline);
11055 save_item(PL_subname);
11056 SAVESPTR(PL_compcv);
11058 PL_compcv = (CV*)newSV(0);
11059 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
11060 CvFLAGS(PL_compcv) |= flags;
11062 PL_subline = CopLINE(PL_curcop);
11063 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11064 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
11065 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11067 return oldsavestack_ix;
11071 #pragma segment Perl_yylex
11074 Perl_yywarn(pTHX_ const char *s)
11077 PL_in_eval |= EVAL_WARNONLY;
11079 PL_in_eval &= ~EVAL_WARNONLY;
11084 Perl_yyerror(pTHX_ const char *s)
11087 const char *where = NULL;
11088 const char *context = NULL;
11092 if (!yychar || (yychar == ';' && !PL_rsfp))
11094 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
11095 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
11096 PL_oldbufptr != PL_bufptr) {
11099 The code below is removed for NetWare because it abends/crashes on NetWare
11100 when the script has error such as not having the closing quotes like:
11101 if ($var eq "value)
11102 Checking of white spaces is anyway done in NetWare code.
11105 while (isSPACE(*PL_oldoldbufptr))
11108 context = PL_oldoldbufptr;
11109 contlen = PL_bufptr - PL_oldoldbufptr;
11111 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
11112 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
11115 The code below is removed for NetWare because it abends/crashes on NetWare
11116 when the script has error such as not having the closing quotes like:
11117 if ($var eq "value)
11118 Checking of white spaces is anyway done in NetWare code.
11121 while (isSPACE(*PL_oldbufptr))
11124 context = PL_oldbufptr;
11125 contlen = PL_bufptr - PL_oldbufptr;
11127 else if (yychar > 255)
11128 where = "next token ???";
11129 else if (yychar == -2) { /* YYEMPTY */
11130 if (PL_lex_state == LEX_NORMAL ||
11131 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
11132 where = "at end of line";
11133 else if (PL_lex_inpat)
11134 where = "within pattern";
11136 where = "within string";
11139 SV * const where_sv = sv_2mortal(newSVpvs("next char "));
11141 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11142 else if (isPRINT_LC(yychar))
11143 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
11145 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11146 where = SvPVX_const(where_sv);
11148 msg = sv_2mortal(newSVpv(s, 0));
11149 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
11150 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11152 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
11154 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
11155 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
11156 Perl_sv_catpvf(aTHX_ msg,
11157 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
11158 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11161 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
11162 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
11165 if (PL_error_count >= 10) {
11166 if (PL_in_eval && SvCUR(ERRSV))
11167 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
11168 ERRSV, OutCopFILE(PL_curcop));
11170 Perl_croak(aTHX_ "%s has too many errors.\n",
11171 OutCopFILE(PL_curcop));
11174 PL_in_my_stash = NULL;
11178 #pragma segment Main
11182 S_swallow_bom(pTHX_ U8 *s)
11185 const STRLEN slen = SvCUR(PL_linestr);
11188 if (s[1] == 0xFE) {
11189 /* UTF-16 little-endian? (or UTF32-LE?) */
11190 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11191 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
11192 #ifndef PERL_NO_UTF16_FILTER
11193 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
11196 if (PL_bufend > (char*)s) {
11200 filter_add(utf16rev_textfilter, NULL);
11201 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
11202 utf16_to_utf8_reversed(s, news,
11203 PL_bufend - (char*)s - 1,
11205 sv_setpvn(PL_linestr, (const char*)news, newlen);
11207 SvUTF8_on(PL_linestr);
11208 s = (U8*)SvPVX(PL_linestr);
11209 PL_bufend = SvPVX(PL_linestr) + newlen;
11212 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
11217 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11218 #ifndef PERL_NO_UTF16_FILTER
11219 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11222 if (PL_bufend > (char *)s) {
11226 filter_add(utf16_textfilter, NULL);
11227 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
11228 utf16_to_utf8(s, news,
11229 PL_bufend - (char*)s,
11231 sv_setpvn(PL_linestr, (const char*)news, newlen);
11233 SvUTF8_on(PL_linestr);
11234 s = (U8*)SvPVX(PL_linestr);
11235 PL_bufend = SvPVX(PL_linestr) + newlen;
11238 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
11243 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
11244 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11245 s += 3; /* UTF-8 */
11251 if (s[2] == 0xFE && s[3] == 0xFF) {
11252 /* UTF-32 big-endian */
11253 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
11256 else if (s[2] == 0 && s[3] != 0) {
11259 * are a good indicator of UTF-16BE. */
11260 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11265 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11268 * are a good indicator of UTF-16LE. */
11269 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11278 * Restore a source filter.
11282 restore_rsfp(pTHX_ void *f)
11285 PerlIO * const fp = (PerlIO*)f;
11287 if (PL_rsfp == PerlIO_stdin())
11288 PerlIO_clearerr(PL_rsfp);
11289 else if (PL_rsfp && (PL_rsfp != fp))
11290 PerlIO_close(PL_rsfp);
11294 #ifndef PERL_NO_UTF16_FILTER
11296 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11299 const STRLEN old = SvCUR(sv);
11300 const I32 count = FILTER_READ(idx+1, sv, maxlen);
11301 DEBUG_P(PerlIO_printf(Perl_debug_log,
11302 "utf16_textfilter(%p): %d %d (%d)\n",
11303 utf16_textfilter, idx, maxlen, (int) count));
11307 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
11308 Copy(SvPVX_const(sv), tmps, old, char);
11309 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
11310 SvCUR(sv) - old, &newlen);
11311 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
11313 DEBUG_P({sv_dump(sv);});
11318 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11321 const STRLEN old = SvCUR(sv);
11322 const I32 count = FILTER_READ(idx+1, sv, maxlen);
11323 DEBUG_P(PerlIO_printf(Perl_debug_log,
11324 "utf16rev_textfilter(%p): %d %d (%d)\n",
11325 utf16rev_textfilter, idx, maxlen, (int) count));
11329 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
11330 Copy(SvPVX_const(sv), tmps, old, char);
11331 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
11332 SvCUR(sv) - old, &newlen);
11333 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
11335 DEBUG_P({ sv_dump(sv); });
11341 Returns a pointer to the next character after the parsed
11342 vstring, as well as updating the passed in sv.
11344 Function must be called like
11347 s = scan_vstring(s,sv);
11349 The sv should already be large enough to store the vstring
11350 passed in, for performance reasons.
11355 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
11358 const char *pos = s;
11359 const char *start = s;
11360 if (*pos == 'v') pos++; /* get past 'v' */
11361 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11363 if ( *pos != '.') {
11364 /* this may not be a v-string if followed by => */
11365 const char *next = pos;
11366 while (next < PL_bufend && isSPACE(*next))
11368 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
11369 /* return string not v-string */
11370 sv_setpvn(sv,(char *)s,pos-s);
11371 return (char *)pos;
11375 if (!isALPHA(*pos)) {
11376 U8 tmpbuf[UTF8_MAXBYTES+1];
11378 if (*s == 'v') s++; /* get past 'v' */
11380 sv_setpvn(sv, "", 0);
11386 /* this is atoi() that tolerates underscores */
11387 const char *end = pos;
11389 while (--end >= s) {
11394 rev += (*end - '0') * mult;
11396 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11397 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11398 "Integer overflow in decimal number");
11402 if (rev > 0x7FFFFFFF)
11403 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11405 /* Append native character for the rev point */
11406 tmpend = uvchr_to_utf8(tmpbuf, rev);
11407 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11408 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11410 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11416 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11420 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11428 * c-indentation-style: bsd
11429 * c-basic-offset: 4
11430 * indent-tabs-mode: t
11433 * ex: set ts=8 sts=4 sw=4 noet: