3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It all comes from here, the stench and the peril." --Frodo
16 * This file is the lexer for Perl. It's closely linked to the
19 * The main routine is yylex(), which returns the next token.
23 #define PERL_IN_TOKE_C
26 #define yychar (*PL_yycharp)
27 #define yylval (*PL_yylvalp)
29 static const char ident_too_long[] =
30 "Identifier too long";
31 static const char c_without_g[] =
32 "Use of /c modifier is meaningless without /g";
33 static const char c_in_subst[] =
34 "Use of /c modifier is meaningless in s///";
36 static void restore_rsfp(pTHX_ void *f);
37 #ifndef PERL_NO_UTF16_FILTER
38 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
39 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
42 #define XFAKEBRACK 128
45 #ifdef USE_UTF8_SCRIPTS
46 # define UTF (!IN_BYTES)
48 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
51 /* In variables named $^X, these are the legal values for X.
52 * 1999-02-27 mjd-perl-patch@plover.com */
53 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
55 /* On MacOS, respect nonbreaking spaces */
56 #ifdef MACOS_TRADITIONAL
57 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
59 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
62 /* LEX_* are values for PL_lex_state, the state of the lexer.
63 * They are arranged oddly so that the guard on the switch statement
64 * can get by with a single comparison (if the compiler is smart enough).
67 /* #define LEX_NOTPARSING 11 is done in perl.h. */
70 #define LEX_INTERPNORMAL 9
71 #define LEX_INTERPCASEMOD 8
72 #define LEX_INTERPPUSH 7
73 #define LEX_INTERPSTART 6
74 #define LEX_INTERPEND 5
75 #define LEX_INTERPENDMAYBE 4
76 #define LEX_INTERPCONCAT 3
77 #define LEX_INTERPCONST 2
78 #define LEX_FORMLINE 1
79 #define LEX_KNOWNEXT 0
82 static const char* const lex_state_names[] = {
101 #include "keywords.h"
103 /* CLINE is a macro that ensures PL_copline has a sane value */
108 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
111 * Convenience functions to return different tokens and prime the
112 * lexer for the next token. They all take an argument.
114 * TOKEN : generic token (used for '(', DOLSHARP, etc)
115 * OPERATOR : generic operator
116 * AOPERATOR : assignment operator
117 * PREBLOCK : beginning the block after an if, while, foreach, ...
118 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
119 * PREREF : *EXPR where EXPR is not a simple identifier
120 * TERM : expression term
121 * LOOPX : loop exiting command (goto, last, dump, etc)
122 * FTST : file test operator
123 * FUN0 : zero-argument function
124 * FUN1 : not used, except for not, which isn't a UNIOP
125 * BOop : bitwise or or xor
127 * SHop : shift operator
128 * PWop : power operator
129 * PMop : pattern-matching operator
130 * Aop : addition-level operator
131 * Mop : multiplication-level operator
132 * Eop : equality-testing operator
133 * Rop : relational operator <= != gt
135 * Also see LOP and lop() below.
138 #ifdef DEBUGGING /* Serve -DT. */
139 # define REPORT(retval) tokereport(s,(int)retval)
141 # define REPORT(retval) (retval)
144 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
145 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
146 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
147 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
148 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
149 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
150 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
151 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
152 #define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
153 #define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
154 #define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
155 #define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
156 #define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
157 #define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
158 #define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
159 #define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
160 #define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
161 #define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
162 #define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
163 #define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
165 /* This bit of chicanery makes a unary function followed by
166 * a parenthesis into a function with one argument, highest precedence.
167 * The UNIDOR macro is for unary functions that can be followed by the //
168 * operator (such as C<shift // 0>).
170 #define UNI2(f,x) { \
174 PL_last_uni = PL_oldbufptr; \
175 PL_last_lop_op = f; \
177 return REPORT( (int)FUNC1 ); \
179 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
181 #define UNI(f) UNI2(f,XTERM)
182 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
184 #define UNIBRACK(f) { \
187 PL_last_uni = PL_oldbufptr; \
189 return REPORT( (int)FUNC1 ); \
191 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
194 /* grandfather return to old style */
195 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
199 /* how to interpret the yylval associated with the token */
203 TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
209 static struct debug_tokens { const int token, type; const char *name; }
210 const debug_tokens[] =
212 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
213 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
214 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
215 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
216 { ARROW, TOKENTYPE_NONE, "ARROW" },
217 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
218 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
219 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
220 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
221 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
222 { DO, TOKENTYPE_NONE, "DO" },
223 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
224 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
225 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
226 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
227 { ELSE, TOKENTYPE_NONE, "ELSE" },
228 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
229 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
230 { FOR, TOKENTYPE_IVAL, "FOR" },
231 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
232 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
233 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
234 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
235 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
236 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
237 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
238 { IF, TOKENTYPE_IVAL, "IF" },
239 { LABEL, TOKENTYPE_PVAL, "LABEL" },
240 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
241 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
242 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
243 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
244 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
245 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
246 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
247 { MY, TOKENTYPE_IVAL, "MY" },
248 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
249 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
250 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
251 { OROP, TOKENTYPE_IVAL, "OROP" },
252 { OROR, TOKENTYPE_NONE, "OROR" },
253 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
254 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
255 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
256 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
257 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
258 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
259 { PREINC, TOKENTYPE_NONE, "PREINC" },
260 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
261 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
262 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
263 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
264 { SUB, TOKENTYPE_NONE, "SUB" },
265 { THING, TOKENTYPE_OPVAL, "THING" },
266 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
267 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
268 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
269 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
270 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
271 { USE, TOKENTYPE_IVAL, "USE" },
272 { WHILE, TOKENTYPE_IVAL, "WHILE" },
273 { WORD, TOKENTYPE_OPVAL, "WORD" },
274 { 0, TOKENTYPE_NONE, 0 }
277 /* dump the returned token in rv, plus any optional arg in yylval */
280 S_tokereport(pTHX_ const char* s, I32 rv)
283 const char *name = Nullch;
284 enum token_type type = TOKENTYPE_NONE;
285 const struct debug_tokens *p;
286 SV* const report = newSVpvn("<== ", 4);
288 for (p = debug_tokens; p->token; p++) {
289 if (p->token == (int)rv) {
296 Perl_sv_catpv(aTHX_ report, name);
297 else if ((char)rv > ' ' && (char)rv < '~')
298 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
300 Perl_sv_catpv(aTHX_ report, "EOF");
302 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
305 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
308 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
310 case TOKENTYPE_OPNUM:
311 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
312 PL_op_name[yylval.ival]);
315 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
317 case TOKENTYPE_OPVAL:
319 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
320 PL_op_name[yylval.opval->op_type]);
322 Perl_sv_catpv(aTHX_ report, "(opval=null)");
325 Perl_sv_catpvf(aTHX_ report, " at line %"IVdf" [", (IV)CopLINE(PL_curcop));
326 if (s - PL_bufptr > 0)
327 sv_catpvn(report, PL_bufptr, s - PL_bufptr);
329 if (PL_oldbufptr && *PL_oldbufptr)
330 sv_catpv(report, PL_tokenbuf);
332 PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen_const(report));
342 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
343 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
347 S_ao(pTHX_ int toketype)
349 if (*PL_bufptr == '=') {
351 if (toketype == ANDAND)
352 yylval.ival = OP_ANDASSIGN;
353 else if (toketype == OROR)
354 yylval.ival = OP_ORASSIGN;
355 else if (toketype == DORDOR)
356 yylval.ival = OP_DORASSIGN;
364 * When Perl expects an operator and finds something else, no_op
365 * prints the warning. It always prints "<something> found where
366 * operator expected. It prints "Missing semicolon on previous line?"
367 * if the surprise occurs at the start of the line. "do you need to
368 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
369 * where the compiler doesn't know if foo is a method call or a function.
370 * It prints "Missing operator before end of line" if there's nothing
371 * after the missing operator, or "... before <...>" if there is something
372 * after the missing operator.
376 S_no_op(pTHX_ const char *what, char *s)
378 char * const oldbp = PL_bufptr;
379 const bool is_first = (PL_oldbufptr == PL_linestart);
385 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
386 if (ckWARN_d(WARN_SYNTAX)) {
388 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
389 "\t(Missing semicolon on previous line?)\n");
390 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
392 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
393 if (t < PL_bufptr && isSPACE(*t))
394 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
395 "\t(Do you need to predeclare %.*s?)\n",
396 t - PL_oldoldbufptr, PL_oldoldbufptr);
400 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
401 "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
409 * Complain about missing quote/regexp/heredoc terminator.
410 * If it's called with (char *)NULL then it cauterizes the line buffer.
411 * If we're in a delimited string and the delimiter is a control
412 * character, it's reformatted into a two-char sequence like ^C.
417 S_missingterm(pTHX_ char *s)
422 char * const nl = strrchr(s,'\n');
428 iscntrl(PL_multi_close)
430 PL_multi_close < 32 || PL_multi_close == 127
434 tmpbuf[1] = toCTRL(PL_multi_close);
439 *tmpbuf = (char)PL_multi_close;
443 q = strchr(s,'"') ? '\'' : '"';
444 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
452 Perl_deprecate(pTHX_ const char *s)
454 if (ckWARN(WARN_DEPRECATED))
455 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
459 Perl_deprecate_old(pTHX_ const char *s)
461 /* This function should NOT be called for any new deprecated warnings */
462 /* Use Perl_deprecate instead */
464 /* It is here to maintain backward compatibility with the pre-5.8 */
465 /* warnings category hierarchy. The "deprecated" category used to */
466 /* live under the "syntax" category. It is now a top-level category */
467 /* in its own right. */
469 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
470 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
471 "Use of %s is deprecated", s);
476 * Deprecate a comma-less variable list.
482 deprecate_old("comma-less variable list");
486 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
487 * utf16-to-utf8-reversed.
490 #ifdef PERL_CR_FILTER
494 register const char *s = SvPVX_const(sv);
495 register const char * const e = s + SvCUR(sv);
496 /* outer loop optimized to do nothing if there are no CR-LFs */
498 if (*s++ == '\r' && *s == '\n') {
499 /* hit a CR-LF, need to copy the rest */
500 register char *d = s - 1;
503 if (*s == '\r' && s[1] == '\n')
514 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
516 const I32 count = FILTER_READ(idx+1, sv, maxlen);
517 if (count > 0 && !maxlen)
525 * Initialize variables. Uses the Perl save_stack to save its state (for
526 * recursive calls to the parser).
530 Perl_lex_start(pTHX_ SV *line)
535 SAVEI32(PL_lex_dojoin);
536 SAVEI32(PL_lex_brackets);
537 SAVEI32(PL_lex_casemods);
538 SAVEI32(PL_lex_starts);
539 SAVEI32(PL_lex_state);
540 SAVEVPTR(PL_lex_inpat);
541 SAVEI32(PL_lex_inwhat);
542 if (PL_lex_state == LEX_KNOWNEXT) {
543 I32 toke = PL_nexttoke;
544 while (--toke >= 0) {
545 SAVEI32(PL_nexttype[toke]);
546 SAVEVPTR(PL_nextval[toke]);
548 SAVEI32(PL_nexttoke);
550 SAVECOPLINE(PL_curcop);
553 SAVEPPTR(PL_oldbufptr);
554 SAVEPPTR(PL_oldoldbufptr);
555 SAVEPPTR(PL_last_lop);
556 SAVEPPTR(PL_last_uni);
557 SAVEPPTR(PL_linestart);
558 SAVESPTR(PL_linestr);
559 SAVEGENERICPV(PL_lex_brackstack);
560 SAVEGENERICPV(PL_lex_casestack);
561 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
562 SAVESPTR(PL_lex_stuff);
563 SAVEI32(PL_lex_defer);
564 SAVEI32(PL_sublex_info.sub_inwhat);
565 SAVESPTR(PL_lex_repl);
567 SAVEINT(PL_lex_expect);
569 PL_lex_state = LEX_NORMAL;
573 Newx(PL_lex_brackstack, 120, char);
574 Newx(PL_lex_casestack, 12, char);
576 *PL_lex_casestack = '\0';
579 PL_lex_stuff = Nullsv;
580 PL_lex_repl = Nullsv;
584 PL_sublex_info.sub_inwhat = 0;
586 if (SvREADONLY(PL_linestr))
587 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
588 s = SvPV_const(PL_linestr, len);
589 if (!len || s[len-1] != ';') {
590 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
591 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
592 sv_catpvn(PL_linestr, "\n;", 2);
594 SvTEMP_off(PL_linestr);
595 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
596 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
597 PL_last_lop = PL_last_uni = Nullch;
603 * Finalizer for lexing operations. Must be called when the parser is
604 * done with the lexer.
610 PL_doextract = FALSE;
615 * This subroutine has nothing to do with tilting, whether at windmills
616 * or pinball tables. Its name is short for "increment line". It
617 * increments the current line number in CopLINE(PL_curcop) and checks
618 * to see whether the line starts with a comment of the form
619 * # line 500 "foo.pm"
620 * If so, it sets the current line number and file to the values in the comment.
624 S_incline(pTHX_ char *s)
631 CopLINE_inc(PL_curcop);
634 while (SPACE_OR_TAB(*s)) s++;
635 if (strnEQ(s, "line", 4))
639 if (SPACE_OR_TAB(*s))
643 while (SPACE_OR_TAB(*s)) s++;
649 while (SPACE_OR_TAB(*s))
651 if (*s == '"' && (t = strchr(s+1, '"'))) {
656 for (t = s; !isSPACE(*t); t++) ;
659 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
661 if (*e != '\n' && *e != '\0')
662 return; /* false alarm */
668 const char *cf = CopFILE(PL_curcop);
669 if (cf && strlen(cf) > 7 && strnEQ(cf, "(eval ", 6)) {
670 /* must copy *{"::_<(eval N)[oldfilename:L]"}
671 * to *{"::_<newfilename"} */
672 char smallbuf[256], smallbuf2[256];
673 char *tmpbuf, *tmpbuf2;
675 STRLEN tmplen = strlen(cf);
676 STRLEN tmplen2 = strlen(s);
677 if (tmplen + 3 < sizeof smallbuf)
680 Newx(tmpbuf, tmplen + 3, char);
681 if (tmplen2 + 3 < sizeof smallbuf2)
684 Newx(tmpbuf2, tmplen2 + 3, char);
685 tmpbuf[0] = tmpbuf2[0] = '_';
686 tmpbuf[1] = tmpbuf2[1] = '<';
687 memcpy(tmpbuf + 2, cf, ++tmplen);
688 memcpy(tmpbuf2 + 2, s, ++tmplen2);
690 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
692 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
694 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
695 /* adjust ${"::_<newfilename"} to store the new file name */
696 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
697 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
698 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
700 if (tmpbuf != smallbuf) Safefree(tmpbuf);
701 if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
704 CopFILE_free(PL_curcop);
705 CopFILE_set(PL_curcop, s);
708 CopLINE_set(PL_curcop, atoi(n)-1);
713 * Called to gobble the appropriate amount and type of whitespace.
714 * Skips comments as well.
718 S_skipspace(pTHX_ register char *s)
720 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
721 while (s < PL_bufend && SPACE_OR_TAB(*s))
727 SSize_t oldprevlen, oldoldprevlen;
728 SSize_t oldloplen = 0, oldunilen = 0;
729 while (s < PL_bufend && isSPACE(*s)) {
730 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
735 if (s < PL_bufend && *s == '#') {
736 while (s < PL_bufend && *s != '\n')
740 if (PL_in_eval && !PL_rsfp) {
747 /* only continue to recharge the buffer if we're at the end
748 * of the buffer, we're not reading from a source filter, and
749 * we're in normal lexing mode
751 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
752 PL_lex_state == LEX_FORMLINE)
755 /* try to recharge the buffer */
756 if ((s = filter_gets(PL_linestr, PL_rsfp,
757 (prevlen = SvCUR(PL_linestr)))) == Nullch)
759 /* end of file. Add on the -p or -n magic */
762 ";}continue{print or die qq(-p destination: $!\\n);}");
763 PL_minus_n = PL_minus_p = 0;
765 else if (PL_minus_n) {
766 sv_setpvn(PL_linestr, ";}", 2);
770 sv_setpvn(PL_linestr,";", 1);
772 /* reset variables for next time we lex */
773 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
775 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
776 PL_last_lop = PL_last_uni = Nullch;
778 /* Close the filehandle. Could be from -P preprocessor,
779 * STDIN, or a regular file. If we were reading code from
780 * STDIN (because the commandline held no -e or filename)
781 * then we don't close it, we reset it so the code can
782 * read from STDIN too.
785 if (PL_preprocess && !PL_in_eval)
786 (void)PerlProc_pclose(PL_rsfp);
787 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
788 PerlIO_clearerr(PL_rsfp);
790 (void)PerlIO_close(PL_rsfp);
795 /* not at end of file, so we only read another line */
796 /* make corresponding updates to old pointers, for yyerror() */
797 oldprevlen = PL_oldbufptr - PL_bufend;
798 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
800 oldunilen = PL_last_uni - PL_bufend;
802 oldloplen = PL_last_lop - PL_bufend;
803 PL_linestart = PL_bufptr = s + prevlen;
804 PL_bufend = s + SvCUR(PL_linestr);
806 PL_oldbufptr = s + oldprevlen;
807 PL_oldoldbufptr = s + oldoldprevlen;
809 PL_last_uni = s + oldunilen;
811 PL_last_lop = s + oldloplen;
814 /* debugger active and we're not compiling the debugger code,
815 * so store the line into the debugger's array of lines
817 if (PERLDB_LINE && PL_curstash != PL_debstash) {
818 SV * const sv = NEWSV(85,0);
820 sv_upgrade(sv, SVt_PVMG);
821 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
824 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
831 * Check the unary operators to ensure there's no ambiguity in how they're
832 * used. An ambiguous piece of code would be:
834 * This doesn't mean rand() + 5. Because rand() is a unary operator,
835 * the +5 is its argument.
844 if (PL_oldoldbufptr != PL_last_uni)
846 while (isSPACE(*PL_last_uni))
848 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
849 if ((t = strchr(s, '(')) && t < PL_bufptr)
851 if (ckWARN_d(WARN_AMBIGUOUS)){
854 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
855 "Warning: Use of \"%s\" without parentheses is ambiguous",
862 * LOP : macro to build a list operator. Its behaviour has been replaced
863 * with a subroutine, S_lop() for which LOP is just another name.
866 #define LOP(f,x) return lop(f,x,s)
870 * Build a list operator (or something that might be one). The rules:
871 * - if we have a next token, then it's a list operator [why?]
872 * - if the next thing is an opening paren, then it's a function
873 * - else it's a list operator
877 S_lop(pTHX_ I32 f, int x, char *s)
883 PL_last_lop = PL_oldbufptr;
884 PL_last_lop_op = (OPCODE)f;
886 return REPORT(LSTOP);
893 return REPORT(LSTOP);
898 * When the lexer realizes it knows the next token (for instance,
899 * it is reordering tokens for the parser) then it can call S_force_next
900 * to know what token to return the next time the lexer is called. Caller
901 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
902 * handles the token correctly.
906 S_force_next(pTHX_ I32 type)
908 PL_nexttype[PL_nexttoke] = type;
910 if (PL_lex_state != LEX_KNOWNEXT) {
911 PL_lex_defer = PL_lex_state;
912 PL_lex_expect = PL_expect;
913 PL_lex_state = LEX_KNOWNEXT;
918 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
920 SV * const sv = newSVpvn(start,len);
921 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
928 * When the lexer knows the next thing is a word (for instance, it has
929 * just seen -> and it knows that the next char is a word char, then
930 * it calls S_force_word to stick the next word into the PL_next lookahead.
933 * char *start : buffer position (must be within PL_linestr)
934 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
935 * int check_keyword : if true, Perl checks to make sure the word isn't
936 * a keyword (do this if the word is a label, e.g. goto FOO)
937 * int allow_pack : if true, : characters will also be allowed (require,
939 * int allow_initial_tick : used by the "sub" lexer only.
943 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
948 start = skipspace(start);
950 if (isIDFIRST_lazy_if(s,UTF) ||
951 (allow_pack && *s == ':') ||
952 (allow_initial_tick && *s == '\'') )
954 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
955 if (check_keyword && keyword(PL_tokenbuf, len))
957 if (token == METHOD) {
962 PL_expect = XOPERATOR;
965 PL_nextval[PL_nexttoke].opval
966 = (OP*)newSVOP(OP_CONST,0,
967 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
968 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
976 * Called when the lexer wants $foo *foo &foo etc, but the program
977 * text only contains the "foo" portion. The first argument is a pointer
978 * to the "foo", and the second argument is the type symbol to prefix.
979 * Forces the next token to be a "WORD".
980 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
984 S_force_ident(pTHX_ register const char *s, int kind)
987 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
988 PL_nextval[PL_nexttoke].opval = o;
991 o->op_private = OPpCONST_ENTERED;
992 /* XXX see note in pp_entereval() for why we forgo typo
993 warnings if the symbol must be introduced in an eval.
995 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
996 kind == '$' ? SVt_PV :
997 kind == '@' ? SVt_PVAV :
998 kind == '%' ? SVt_PVHV :
1006 Perl_str_to_version(pTHX_ SV *sv)
1011 const char *start = SvPV_const(sv,len);
1012 const char * const end = start + len;
1013 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1014 while (start < end) {
1018 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1023 retval += ((NV)n)/nshift;
1032 * Forces the next token to be a version number.
1033 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1034 * and if "guessing" is TRUE, then no new token is created (and the caller
1035 * must use an alternative parsing method).
1039 S_force_version(pTHX_ char *s, int guessing)
1041 OP *version = Nullop;
1050 while (isDIGIT(*d) || *d == '_' || *d == '.')
1052 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1054 s = scan_num(s, &yylval);
1055 version = yylval.opval;
1056 ver = cSVOPx(version)->op_sv;
1057 if (SvPOK(ver) && !SvNIOK(ver)) {
1058 SvUPGRADE(ver, SVt_PVNV);
1059 SvNV_set(ver, str_to_version(ver));
1060 SvNOK_on(ver); /* hint that it is a version */
1067 /* NOTE: The parser sees the package name and the VERSION swapped */
1068 PL_nextval[PL_nexttoke].opval = version;
1076 * Tokenize a quoted string passed in as an SV. It finds the next
1077 * chunk, up to end of string or a backslash. It may make a new
1078 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1083 S_tokeq(pTHX_ SV *sv)
1086 register char *send;
1094 s = SvPV_force(sv, len);
1095 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1098 while (s < send && *s != '\\')
1103 if ( PL_hints & HINT_NEW_STRING ) {
1104 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1110 if (s + 1 < send && (s[1] == '\\'))
1111 s++; /* all that, just for this */
1116 SvCUR_set(sv, d - SvPVX_const(sv));
1118 if ( PL_hints & HINT_NEW_STRING )
1119 return new_constant(NULL, 0, "q", sv, pv, "q");
1124 * Now come three functions related to double-quote context,
1125 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1126 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1127 * interact with PL_lex_state, and create fake ( ... ) argument lists
1128 * to handle functions and concatenation.
1129 * They assume that whoever calls them will be setting up a fake
1130 * join call, because each subthing puts a ',' after it. This lets
1133 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1135 * (I'm not sure whether the spurious commas at the end of lcfirst's
1136 * arguments and join's arguments are created or not).
1141 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1143 * Pattern matching will set PL_lex_op to the pattern-matching op to
1144 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1146 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1148 * Everything else becomes a FUNC.
1150 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1151 * had an OP_CONST or OP_READLINE). This just sets us up for a
1152 * call to S_sublex_push().
1156 S_sublex_start(pTHX)
1158 const register I32 op_type = yylval.ival;
1160 if (op_type == OP_NULL) {
1161 yylval.opval = PL_lex_op;
1165 if (op_type == OP_CONST || op_type == OP_READLINE) {
1166 SV *sv = tokeq(PL_lex_stuff);
1168 if (SvTYPE(sv) == SVt_PVIV) {
1169 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1171 const char *p = SvPV_const(sv, len);
1172 SV * const nsv = newSVpvn(p, len);
1178 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1179 PL_lex_stuff = Nullsv;
1180 /* Allow <FH> // "foo" */
1181 if (op_type == OP_READLINE)
1182 PL_expect = XTERMORDORDOR;
1186 PL_sublex_info.super_state = PL_lex_state;
1187 PL_sublex_info.sub_inwhat = op_type;
1188 PL_sublex_info.sub_op = PL_lex_op;
1189 PL_lex_state = LEX_INTERPPUSH;
1193 yylval.opval = PL_lex_op;
1203 * Create a new scope to save the lexing state. The scope will be
1204 * ended in S_sublex_done. Returns a '(', starting the function arguments
1205 * to the uc, lc, etc. found before.
1206 * Sets PL_lex_state to LEX_INTERPCONCAT.
1215 PL_lex_state = PL_sublex_info.super_state;
1216 SAVEI32(PL_lex_dojoin);
1217 SAVEI32(PL_lex_brackets);
1218 SAVEI32(PL_lex_casemods);
1219 SAVEI32(PL_lex_starts);
1220 SAVEI32(PL_lex_state);
1221 SAVEVPTR(PL_lex_inpat);
1222 SAVEI32(PL_lex_inwhat);
1223 SAVECOPLINE(PL_curcop);
1224 SAVEPPTR(PL_bufptr);
1225 SAVEPPTR(PL_bufend);
1226 SAVEPPTR(PL_oldbufptr);
1227 SAVEPPTR(PL_oldoldbufptr);
1228 SAVEPPTR(PL_last_lop);
1229 SAVEPPTR(PL_last_uni);
1230 SAVEPPTR(PL_linestart);
1231 SAVESPTR(PL_linestr);
1232 SAVEGENERICPV(PL_lex_brackstack);
1233 SAVEGENERICPV(PL_lex_casestack);
1235 PL_linestr = PL_lex_stuff;
1236 PL_lex_stuff = Nullsv;
1238 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1239 = SvPVX(PL_linestr);
1240 PL_bufend += SvCUR(PL_linestr);
1241 PL_last_lop = PL_last_uni = Nullch;
1242 SAVEFREESV(PL_linestr);
1244 PL_lex_dojoin = FALSE;
1245 PL_lex_brackets = 0;
1246 Newx(PL_lex_brackstack, 120, char);
1247 Newx(PL_lex_casestack, 12, char);
1248 PL_lex_casemods = 0;
1249 *PL_lex_casestack = '\0';
1251 PL_lex_state = LEX_INTERPCONCAT;
1252 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1254 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1255 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1256 PL_lex_inpat = PL_sublex_info.sub_op;
1258 PL_lex_inpat = Nullop;
1265 * Restores lexer state after a S_sublex_push.
1272 if (!PL_lex_starts++) {
1273 SV * const sv = newSVpvn("",0);
1274 if (SvUTF8(PL_linestr))
1276 PL_expect = XOPERATOR;
1277 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1281 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1282 PL_lex_state = LEX_INTERPCASEMOD;
1286 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1287 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1288 PL_linestr = PL_lex_repl;
1290 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1291 PL_bufend += SvCUR(PL_linestr);
1292 PL_last_lop = PL_last_uni = Nullch;
1293 SAVEFREESV(PL_linestr);
1294 PL_lex_dojoin = FALSE;
1295 PL_lex_brackets = 0;
1296 PL_lex_casemods = 0;
1297 *PL_lex_casestack = '\0';
1299 if (SvEVALED(PL_lex_repl)) {
1300 PL_lex_state = LEX_INTERPNORMAL;
1302 /* we don't clear PL_lex_repl here, so that we can check later
1303 whether this is an evalled subst; that means we rely on the
1304 logic to ensure sublex_done() is called again only via the
1305 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1308 PL_lex_state = LEX_INTERPCONCAT;
1309 PL_lex_repl = Nullsv;
1315 PL_bufend = SvPVX(PL_linestr);
1316 PL_bufend += SvCUR(PL_linestr);
1317 PL_expect = XOPERATOR;
1318 PL_sublex_info.sub_inwhat = 0;
1326 Extracts a pattern, double-quoted string, or transliteration. This
1329 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1330 processing a pattern (PL_lex_inpat is true), a transliteration
1331 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1333 Returns a pointer to the character scanned up to. Iff this is
1334 advanced from the start pointer supplied (ie if anything was
1335 successfully parsed), will leave an OP for the substring scanned
1336 in yylval. Caller must intuit reason for not parsing further
1337 by looking at the next characters herself.
1341 double-quoted style: \r and \n
1342 regexp special ones: \D \s
1344 backrefs: \1 (deprecated in substitution replacements)
1345 case and quoting: \U \Q \E
1346 stops on @ and $, but not for $ as tail anchor
1348 In transliterations:
1349 characters are VERY literal, except for - not at the start or end
1350 of the string, which indicates a range. scan_const expands the
1351 range to the full set of intermediate characters.
1353 In double-quoted strings:
1355 double-quoted style: \r and \n
1357 backrefs: \1 (deprecated)
1358 case and quoting: \U \Q \E
1361 scan_const does *not* construct ops to handle interpolated strings.
1362 It stops processing as soon as it finds an embedded $ or @ variable
1363 and leaves it to the caller to work out what's going on.
1365 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1367 $ in pattern could be $foo or could be tail anchor. Assumption:
1368 it's a tail anchor if $ is the last thing in the string, or if it's
1369 followed by one of ")| \n\t"
1371 \1 (backreferences) are turned into $1
1373 The structure of the code is
1374 while (there's a character to process) {
1375 handle transliteration ranges
1376 skip regexp comments
1377 skip # initiated comments in //x patterns
1378 check for embedded @foo
1379 check for embedded scalars
1381 leave intact backslashes from leave (below)
1382 deprecate \1 in strings and sub replacements
1383 handle string-changing backslashes \l \U \Q \E, etc.
1384 switch (what was escaped) {
1385 handle - in a transliteration (becomes a literal -)
1386 handle \132 octal characters
1387 handle 0x15 hex characters
1388 handle \cV (control V)
1389 handle printf backslashes (\f, \r, \n, etc)
1391 } (end if backslash)
1392 } (end while character to read)
1397 S_scan_const(pTHX_ char *start)
1399 register char *send = PL_bufend; /* end of the constant */
1400 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1401 register char *s = start; /* start of the constant */
1402 register char *d = SvPVX(sv); /* destination for copies */
1403 bool dorange = FALSE; /* are we in a translit range? */
1404 bool didrange = FALSE; /* did we just finish a range? */
1405 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1406 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1409 UV literal_endpoint = 0;
1412 const char *leaveit = /* set of acceptably-backslashed characters */
1414 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1417 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1418 /* If we are doing a trans and we know we want UTF8 set expectation */
1419 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1420 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1424 while (s < send || dorange) {
1425 /* get transliterations out of the way (they're most literal) */
1426 if (PL_lex_inwhat == OP_TRANS) {
1427 /* expand a range A-Z to the full set of characters. AIE! */
1429 I32 i; /* current expanded character */
1430 I32 min; /* first character in range */
1431 I32 max; /* last character in range */
1434 char * const c = (char*)utf8_hop((U8*)d, -1);
1438 *c = (char)UTF_TO_NATIVE(0xff);
1439 /* mark the range as done, and continue */
1445 i = d - SvPVX_const(sv); /* remember current offset */
1446 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1447 d = SvPVX(sv) + i; /* refresh d after realloc */
1448 d -= 2; /* eat the first char and the - */
1450 min = (U8)*d; /* first char in range */
1451 max = (U8)d[1]; /* last char in range */
1455 "Invalid range \"%c-%c\" in transliteration operator",
1456 (char)min, (char)max);
1460 if (literal_endpoint == 2 &&
1461 ((isLOWER(min) && isLOWER(max)) ||
1462 (isUPPER(min) && isUPPER(max)))) {
1464 for (i = min; i <= max; i++)
1466 *d++ = NATIVE_TO_NEED(has_utf8,i);
1468 for (i = min; i <= max; i++)
1470 *d++ = NATIVE_TO_NEED(has_utf8,i);
1475 for (i = min; i <= max; i++)
1478 /* mark the range as done, and continue */
1482 literal_endpoint = 0;
1487 /* range begins (ignore - as first or last char) */
1488 else if (*s == '-' && s+1 < send && s != start) {
1490 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1493 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1503 literal_endpoint = 0;
1508 /* if we get here, we're not doing a transliteration */
1510 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1511 except for the last char, which will be done separately. */
1512 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1514 while (s+1 < send && *s != ')')
1515 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1517 else if (s[2] == '{' /* This should match regcomp.c */
1518 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1521 char *regparse = s + (s[2] == '{' ? 3 : 4);
1524 while (count && (c = *regparse)) {
1525 if (c == '\\' && regparse[1])
1533 if (*regparse != ')')
1534 regparse--; /* Leave one char for continuation. */
1535 while (s < regparse)
1536 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1540 /* likewise skip #-initiated comments in //x patterns */
1541 else if (*s == '#' && PL_lex_inpat &&
1542 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1543 while (s+1 < send && *s != '\n')
1544 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1547 /* check for embedded arrays
1548 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1550 else if (*s == '@' && s[1]
1551 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1554 /* check for embedded scalars. only stop if we're sure it's a
1557 else if (*s == '$') {
1558 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1560 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1561 break; /* in regexp, $ might be tail anchor */
1564 /* End of else if chain - OP_TRANS rejoin rest */
1567 if (*s == '\\' && s+1 < send) {
1570 /* some backslashes we leave behind */
1571 if (*leaveit && *s && strchr(leaveit, *s)) {
1572 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1573 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1577 /* deprecate \1 in strings and substitution replacements */
1578 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1579 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1581 if (ckWARN(WARN_SYNTAX))
1582 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1587 /* string-change backslash escapes */
1588 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1593 /* if we get here, it's either a quoted -, or a digit */
1596 /* quoted - in transliterations */
1598 if (PL_lex_inwhat == OP_TRANS) {
1608 Perl_warner(aTHX_ packWARN(WARN_MISC),
1609 "Unrecognized escape \\%c passed through",
1611 /* default action is to copy the quoted character */
1612 goto default_action;
1615 /* \132 indicates an octal constant */
1616 case '0': case '1': case '2': case '3':
1617 case '4': case '5': case '6': case '7':
1621 uv = grok_oct(s, &len, &flags, NULL);
1624 goto NUM_ESCAPE_INSERT;
1626 /* \x24 indicates a hex constant */
1630 char* const e = strchr(s, '}');
1631 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1632 PERL_SCAN_DISALLOW_PREFIX;
1637 yyerror("Missing right brace on \\x{}");
1641 uv = grok_hex(s, &len, &flags, NULL);
1647 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1648 uv = grok_hex(s, &len, &flags, NULL);
1654 /* Insert oct or hex escaped character.
1655 * There will always enough room in sv since such
1656 * escapes will be longer than any UTF-8 sequence
1657 * they can end up as. */
1659 /* We need to map to chars to ASCII before doing the tests
1662 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1663 if (!has_utf8 && uv > 255) {
1664 /* Might need to recode whatever we have
1665 * accumulated so far if it contains any
1668 * (Can't we keep track of that and avoid
1669 * this rescan? --jhi)
1673 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1674 if (!NATIVE_IS_INVARIANT(*c)) {
1679 const STRLEN offset = d - SvPVX_const(sv);
1681 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1685 while (src >= (const U8 *)SvPVX_const(sv)) {
1686 if (!NATIVE_IS_INVARIANT(*src)) {
1687 const U8 ch = NATIVE_TO_ASCII(*src);
1688 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1689 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1699 if (has_utf8 || uv > 255) {
1700 d = (char*)uvchr_to_utf8((U8*)d, uv);
1702 if (PL_lex_inwhat == OP_TRANS &&
1703 PL_sublex_info.sub_op) {
1704 PL_sublex_info.sub_op->op_private |=
1705 (PL_lex_repl ? OPpTRANS_FROM_UTF
1718 /* \N{LATIN SMALL LETTER A} is a named character */
1722 char* e = strchr(s, '}');
1728 yyerror("Missing right brace on \\N{}");
1732 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1734 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1735 PERL_SCAN_DISALLOW_PREFIX;
1738 uv = grok_hex(s, &len, &flags, NULL);
1740 goto NUM_ESCAPE_INSERT;
1742 res = newSVpvn(s + 1, e - s - 1);
1743 res = new_constant( Nullch, 0, "charnames",
1744 res, Nullsv, "\\N{...}" );
1746 sv_utf8_upgrade(res);
1747 str = SvPV_const(res,len);
1748 #ifdef EBCDIC_NEVER_MIND
1749 /* charnames uses pack U and that has been
1750 * recently changed to do the below uni->native
1751 * mapping, so this would be redundant (and wrong,
1752 * the code point would be doubly converted).
1753 * But leave this in just in case the pack U change
1754 * gets revoked, but the semantics is still
1755 * desireable for charnames. --jhi */
1757 UV uv = utf8_to_uvchr((const U8*)str, 0);
1760 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
1762 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1763 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1764 str = SvPV_const(res, len);
1768 if (!has_utf8 && SvUTF8(res)) {
1769 const char * const ostart = SvPVX_const(sv);
1770 SvCUR_set(sv, d - ostart);
1773 sv_utf8_upgrade(sv);
1774 /* this just broke our allocation above... */
1775 SvGROW(sv, (STRLEN)(send - start));
1776 d = SvPVX(sv) + SvCUR(sv);
1779 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1780 const char * const odest = SvPVX_const(sv);
1782 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1783 d = SvPVX(sv) + (d - odest);
1785 Copy(str, d, len, char);
1792 yyerror("Missing braces on \\N{}");
1795 /* \c is a control character */
1804 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1807 yyerror("Missing control char name in \\c");
1811 /* printf-style backslashes, formfeeds, newlines, etc */
1813 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1816 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1819 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1822 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1825 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1828 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1831 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1837 } /* end if (backslash) */
1844 /* If we started with encoded form, or already know we want it
1845 and then encode the next character */
1846 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1848 const UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1849 const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1852 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1853 const STRLEN off = d - SvPVX_const(sv);
1854 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1856 d = (char*)uvchr_to_utf8((U8*)d, uv);
1860 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1862 } /* while loop to process each character */
1864 /* terminate the string and set up the sv */
1866 SvCUR_set(sv, d - SvPVX_const(sv));
1867 if (SvCUR(sv) >= SvLEN(sv))
1868 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1871 if (PL_encoding && !has_utf8) {
1872 sv_recode_to_utf8(sv, PL_encoding);
1878 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1879 PL_sublex_info.sub_op->op_private |=
1880 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1884 /* shrink the sv if we allocated more than we used */
1885 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1886 SvPV_shrink_to_cur(sv);
1889 /* return the substring (via yylval) only if we parsed anything */
1890 if (s > PL_bufptr) {
1891 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1892 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1894 ( PL_lex_inwhat == OP_TRANS
1896 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1899 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1906 * Returns TRUE if there's more to the expression (e.g., a subscript),
1909 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1911 * ->[ and ->{ return TRUE
1912 * { and [ outside a pattern are always subscripts, so return TRUE
1913 * if we're outside a pattern and it's not { or [, then return FALSE
1914 * if we're in a pattern and the first char is a {
1915 * {4,5} (any digits around the comma) returns FALSE
1916 * if we're in a pattern and the first char is a [
1918 * [SOMETHING] has a funky algorithm to decide whether it's a
1919 * character class or not. It has to deal with things like
1920 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1921 * anything else returns TRUE
1924 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1927 S_intuit_more(pTHX_ register char *s)
1929 if (PL_lex_brackets)
1931 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1933 if (*s != '{' && *s != '[')
1938 /* In a pattern, so maybe we have {n,m}. */
1955 /* On the other hand, maybe we have a character class */
1958 if (*s == ']' || *s == '^')
1961 /* this is terrifying, and it works */
1962 int weight = 2; /* let's weigh the evidence */
1964 unsigned char un_char = 255, last_un_char;
1965 const char * const send = strchr(s,']');
1966 char tmpbuf[sizeof PL_tokenbuf * 4];
1968 if (!send) /* has to be an expression */
1971 Zero(seen,256,char);
1974 else if (isDIGIT(*s)) {
1976 if (isDIGIT(s[1]) && s[2] == ']')
1982 for (; s < send; s++) {
1983 last_un_char = un_char;
1984 un_char = (unsigned char)*s;
1989 weight -= seen[un_char] * 10;
1990 if (isALNUM_lazy_if(s+1,UTF)) {
1991 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1992 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1997 else if (*s == '$' && s[1] &&
1998 strchr("[#!%*<>()-=",s[1])) {
1999 if (/*{*/ strchr("])} =",s[2]))
2008 if (strchr("wds]",s[1]))
2010 else if (seen['\''] || seen['"'])
2012 else if (strchr("rnftbxcav",s[1]))
2014 else if (isDIGIT(s[1])) {
2016 while (s[1] && isDIGIT(s[1]))
2026 if (strchr("aA01! ",last_un_char))
2028 if (strchr("zZ79~",s[1]))
2030 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2031 weight -= 5; /* cope with negative subscript */
2034 if (!isALNUM(last_un_char)
2035 && !(last_un_char == '$' || last_un_char == '@'
2036 || last_un_char == '&')
2037 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2042 if (keyword(tmpbuf, d - tmpbuf))
2045 if (un_char == last_un_char + 1)
2047 weight -= seen[un_char];
2052 if (weight >= 0) /* probably a character class */
2062 * Does all the checking to disambiguate
2064 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2065 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2067 * First argument is the stuff after the first token, e.g. "bar".
2069 * Not a method if bar is a filehandle.
2070 * Not a method if foo is a subroutine prototyped to take a filehandle.
2071 * Not a method if it's really "Foo $bar"
2072 * Method if it's "foo $bar"
2073 * Not a method if it's really "print foo $bar"
2074 * Method if it's really "foo package::" (interpreted as package->foo)
2075 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2076 * Not a method if bar is a filehandle or package, but is quoted with
2081 S_intuit_method(pTHX_ char *start, GV *gv)
2083 char *s = start + (*start == '$');
2084 char tmpbuf[sizeof PL_tokenbuf];
2092 if ((cv = GvCVu(gv))) {
2093 const char *proto = SvPVX_const(cv);
2103 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2104 /* start is the beginning of the possible filehandle/object,
2105 * and s is the end of it
2106 * tmpbuf is a copy of it
2109 if (*start == '$') {
2110 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2115 return *s == '(' ? FUNCMETH : METHOD;
2117 if (!keyword(tmpbuf, len)) {
2118 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2123 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2124 if (indirgv && GvCVu(indirgv))
2126 /* filehandle or package name makes it a method */
2127 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2129 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2130 return 0; /* no assumptions -- "=>" quotes bearword */
2132 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
2133 newSVpvn(tmpbuf,len));
2134 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
2138 return *s == '(' ? FUNCMETH : METHOD;
2146 * Return a string of Perl code to load the debugger. If PERL5DB
2147 * is set, it will return the contents of that, otherwise a
2148 * compile-time require of perl5db.pl.
2155 const char * const pdb = PerlEnv_getenv("PERL5DB");
2159 SETERRNO(0,SS_NORMAL);
2160 return "BEGIN { require 'perl5db.pl' }";
2166 /* Encoded script support. filter_add() effectively inserts a
2167 * 'pre-processing' function into the current source input stream.
2168 * Note that the filter function only applies to the current source file
2169 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2171 * The datasv parameter (which may be NULL) can be used to pass
2172 * private data to this instance of the filter. The filter function
2173 * can recover the SV using the FILTER_DATA macro and use it to
2174 * store private buffers and state information.
2176 * The supplied datasv parameter is upgraded to a PVIO type
2177 * and the IoDIRP/IoANY field is used to store the function pointer,
2178 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2179 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2180 * private use must be set using malloc'd pointers.
2184 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2189 if (!PL_rsfp_filters)
2190 PL_rsfp_filters = newAV();
2192 datasv = NEWSV(255,0);
2193 SvUPGRADE(datasv, SVt_PVIO);
2194 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2195 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2196 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2197 IoANY(datasv), SvPV_nolen(datasv)));
2198 av_unshift(PL_rsfp_filters, 1);
2199 av_store(PL_rsfp_filters, 0, datasv) ;
2204 /* Delete most recently added instance of this filter function. */
2206 Perl_filter_del(pTHX_ filter_t funcp)
2211 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
2213 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2215 /* if filter is on top of stack (usual case) just pop it off */
2216 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2217 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2218 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2219 IoANY(datasv) = (void *)NULL;
2220 sv_free(av_pop(PL_rsfp_filters));
2224 /* we need to search for the correct entry and clear it */
2225 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2229 /* Invoke the idxth filter function for the current rsfp. */
2230 /* maxlen 0 = read one text line */
2232 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2237 if (!PL_rsfp_filters)
2239 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2240 /* Provide a default input filter to make life easy. */
2241 /* Note that we append to the line. This is handy. */
2242 DEBUG_P(PerlIO_printf(Perl_debug_log,
2243 "filter_read %d: from rsfp\n", idx));
2247 const int old_len = SvCUR(buf_sv);
2249 /* ensure buf_sv is large enough */
2250 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2251 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2252 if (PerlIO_error(PL_rsfp))
2253 return -1; /* error */
2255 return 0 ; /* end of file */
2257 SvCUR_set(buf_sv, old_len + len) ;
2260 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2261 if (PerlIO_error(PL_rsfp))
2262 return -1; /* error */
2264 return 0 ; /* end of file */
2267 return SvCUR(buf_sv);
2269 /* Skip this filter slot if filter has been deleted */
2270 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2271 DEBUG_P(PerlIO_printf(Perl_debug_log,
2272 "filter_read %d: skipped (filter deleted)\n",
2274 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2276 /* Get function pointer hidden within datasv */
2277 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2278 DEBUG_P(PerlIO_printf(Perl_debug_log,
2279 "filter_read %d: via function %p (%s)\n",
2280 idx, datasv, SvPV_nolen_const(datasv)));
2281 /* Call function. The function is expected to */
2282 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2283 /* Return: <0:error, =0:eof, >0:not eof */
2284 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2288 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2290 #ifdef PERL_CR_FILTER
2291 if (!PL_rsfp_filters) {
2292 filter_add(S_cr_textfilter,NULL);
2295 if (PL_rsfp_filters) {
2297 SvCUR_set(sv, 0); /* start with empty line */
2298 if (FILTER_READ(0, sv, 0) > 0)
2299 return ( SvPVX(sv) ) ;
2304 return (sv_gets(sv, fp, append));
2308 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2312 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2316 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2317 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2319 return GvHV(gv); /* Foo:: */
2322 /* use constant CLASS => 'MyClass' */
2323 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2325 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2326 pkgname = SvPV_nolen_const(sv);
2330 return gv_stashpv(pkgname, FALSE);
2334 S_tokenize_use(pTHX_ int is_use, char *s) {
2335 if (PL_expect != XSTATE)
2336 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
2337 is_use ? "use" : "no"));
2339 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
2340 s = force_version(s, TRUE);
2341 if (*s == ';' || (s = skipspace(s), *s == ';')) {
2342 PL_nextval[PL_nexttoke].opval = Nullop;
2345 else if (*s == 'v') {
2346 s = force_word(s,WORD,FALSE,TRUE,FALSE);
2347 s = force_version(s, FALSE);
2351 s = force_word(s,WORD,FALSE,TRUE,FALSE);
2352 s = force_version(s, FALSE);
2354 yylval.ival = is_use;
2358 static const char* const exp_name[] =
2359 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2360 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2367 Works out what to call the token just pulled out of the input
2368 stream. The yacc parser takes care of taking the ops we return and
2369 stitching them into a tree.
2375 if read an identifier
2376 if we're in a my declaration
2377 croak if they tried to say my($foo::bar)
2378 build the ops for a my() declaration
2379 if it's an access to a my() variable
2380 are we in a sort block?
2381 croak if my($a); $a <=> $b
2382 build ops for access to a my() variable
2383 if in a dq string, and they've said @foo and we can't find @foo
2385 build ops for a bareword
2386 if we already built the token before, use it.
2391 #pragma segment Perl_yylex
2396 register char *s = PL_bufptr;
2403 I32 orig_keyword = 0;
2406 PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
2407 lex_state_names[PL_lex_state]);
2409 /* check if there's an identifier for us to look at */
2410 if (PL_pending_ident)
2411 return REPORT(S_pending_ident(aTHX));
2413 /* no identifier pending identification */
2415 switch (PL_lex_state) {
2417 case LEX_NORMAL: /* Some compilers will produce faster */
2418 case LEX_INTERPNORMAL: /* code if we comment these out. */
2422 /* when we've already built the next token, just pull it out of the queue */
2425 yylval = PL_nextval[PL_nexttoke];
2427 PL_lex_state = PL_lex_defer;
2428 PL_expect = PL_lex_expect;
2429 PL_lex_defer = LEX_NORMAL;
2431 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2432 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2433 (IV)PL_nexttype[PL_nexttoke]); });
2435 return REPORT(PL_nexttype[PL_nexttoke]);
2437 /* interpolated case modifiers like \L \U, including \Q and \E.
2438 when we get here, PL_bufptr is at the \
2440 case LEX_INTERPCASEMOD:
2442 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2443 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2445 /* handle \E or end of string */
2446 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2448 if (PL_lex_casemods) {
2449 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
2450 PL_lex_casestack[PL_lex_casemods] = '\0';
2452 if (PL_bufptr != PL_bufend
2453 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2455 PL_lex_state = LEX_INTERPCONCAT;
2459 if (PL_bufptr != PL_bufend)
2461 PL_lex_state = LEX_INTERPCONCAT;
2465 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2466 "### Saw case modifier at '%s'\n", PL_bufptr); });
2468 if (s[1] == '\\' && s[2] == 'E') {
2470 PL_lex_state = LEX_INTERPCONCAT;
2474 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2475 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2476 if ((*s == 'L' || *s == 'U') &&
2477 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2478 PL_lex_casestack[--PL_lex_casemods] = '\0';
2481 if (PL_lex_casemods > 10)
2482 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2483 PL_lex_casestack[PL_lex_casemods++] = *s;
2484 PL_lex_casestack[PL_lex_casemods] = '\0';
2485 PL_lex_state = LEX_INTERPCONCAT;
2486 PL_nextval[PL_nexttoke].ival = 0;
2489 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2491 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2493 PL_nextval[PL_nexttoke].ival = OP_LC;
2495 PL_nextval[PL_nexttoke].ival = OP_UC;
2497 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2499 Perl_croak(aTHX_ "panic: yylex");
2503 if (PL_lex_starts) {
2506 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2507 if (PL_lex_casemods == 1 && PL_lex_inpat)
2516 case LEX_INTERPPUSH:
2517 return REPORT(sublex_push());
2519 case LEX_INTERPSTART:
2520 if (PL_bufptr == PL_bufend)
2521 return REPORT(sublex_done());
2522 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2523 "### Interpolated variable at '%s'\n", PL_bufptr); });
2525 PL_lex_dojoin = (*PL_bufptr == '@');
2526 PL_lex_state = LEX_INTERPNORMAL;
2527 if (PL_lex_dojoin) {
2528 PL_nextval[PL_nexttoke].ival = 0;
2530 force_ident("\"", '$');
2531 PL_nextval[PL_nexttoke].ival = 0;
2533 PL_nextval[PL_nexttoke].ival = 0;
2535 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2538 if (PL_lex_starts++) {
2540 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2541 if (!PL_lex_casemods && PL_lex_inpat)
2548 case LEX_INTERPENDMAYBE:
2549 if (intuit_more(PL_bufptr)) {
2550 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2556 if (PL_lex_dojoin) {
2557 PL_lex_dojoin = FALSE;
2558 PL_lex_state = LEX_INTERPCONCAT;
2561 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2562 && SvEVALED(PL_lex_repl))
2564 if (PL_bufptr != PL_bufend)
2565 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2566 PL_lex_repl = Nullsv;
2569 case LEX_INTERPCONCAT:
2571 if (PL_lex_brackets)
2572 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2574 if (PL_bufptr == PL_bufend)
2575 return REPORT(sublex_done());
2577 if (SvIVX(PL_linestr) == '\'') {
2578 SV *sv = newSVsv(PL_linestr);
2581 else if ( PL_hints & HINT_NEW_RE )
2582 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2583 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2587 s = scan_const(PL_bufptr);
2589 PL_lex_state = LEX_INTERPCASEMOD;
2591 PL_lex_state = LEX_INTERPSTART;
2594 if (s != PL_bufptr) {
2595 PL_nextval[PL_nexttoke] = yylval;
2598 if (PL_lex_starts++) {
2599 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2600 if (!PL_lex_casemods && PL_lex_inpat)
2613 PL_lex_state = LEX_NORMAL;
2614 s = scan_formline(PL_bufptr);
2615 if (!PL_lex_formbrack)
2621 PL_oldoldbufptr = PL_oldbufptr;
2624 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
2625 exp_name[PL_expect], s);
2631 if (isIDFIRST_lazy_if(s,UTF))
2633 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2636 goto fake_eof; /* emulate EOF on ^D or ^Z */
2641 if (PL_lex_brackets) {
2642 if (PL_lex_formbrack)
2643 yyerror("Format not terminated");
2645 yyerror("Missing right curly or square bracket");
2647 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2648 "### Tokener got EOF\n");
2652 if (s++ < PL_bufend)
2653 goto retry; /* ignore stray nulls */
2656 if (!PL_in_eval && !PL_preambled) {
2657 PL_preambled = TRUE;
2658 sv_setpv(PL_linestr,incl_perldb());
2659 if (SvCUR(PL_linestr))
2660 sv_catpvn(PL_linestr,";", 1);
2662 while(AvFILLp(PL_preambleav) >= 0) {
2663 SV *tmpsv = av_shift(PL_preambleav);
2664 sv_catsv(PL_linestr, tmpsv);
2665 sv_catpvn(PL_linestr, ";", 1);
2668 sv_free((SV*)PL_preambleav);
2669 PL_preambleav = NULL;
2671 if (PL_minus_n || PL_minus_p) {
2672 sv_catpv(PL_linestr, "LINE: while (<>) {");
2674 sv_catpv(PL_linestr,"chomp;");
2677 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2678 || *PL_splitstr == '"')
2679 && strchr(PL_splitstr + 1, *PL_splitstr))
2680 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2682 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2683 bytes can be used as quoting characters. :-) */
2684 /* The count here deliberately includes the NUL
2685 that terminates the C string constant. This
2686 embeds the opening NUL into the string. */
2687 const char *splits = PL_splitstr;
2688 sv_catpvn(PL_linestr, "our @F=split(q", 15);
2691 if (*splits == '\\')
2692 sv_catpvn(PL_linestr, splits, 1);
2693 sv_catpvn(PL_linestr, splits, 1);
2694 } while (*splits++);
2695 /* This loop will embed the trailing NUL of
2696 PL_linestr as the last thing it does before
2698 sv_catpvn(PL_linestr, ");", 2);
2702 sv_catpv(PL_linestr,"our @F=split(' ');");
2705 sv_catpvn(PL_linestr, "\n", 1);
2706 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2707 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2708 PL_last_lop = PL_last_uni = Nullch;
2709 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2710 SV * const sv = NEWSV(85,0);
2712 sv_upgrade(sv, SVt_PVMG);
2713 sv_setsv(sv,PL_linestr);
2716 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2721 bof = PL_rsfp ? TRUE : FALSE;
2722 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2725 if (PL_preprocess && !PL_in_eval)
2726 (void)PerlProc_pclose(PL_rsfp);
2727 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2728 PerlIO_clearerr(PL_rsfp);
2730 (void)PerlIO_close(PL_rsfp);
2732 PL_doextract = FALSE;
2734 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2735 sv_setpv(PL_linestr,PL_minus_p
2736 ? ";}continue{print;}" : ";}");
2737 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2738 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2739 PL_last_lop = PL_last_uni = Nullch;
2740 PL_minus_n = PL_minus_p = 0;
2743 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2744 PL_last_lop = PL_last_uni = Nullch;
2745 sv_setpvn(PL_linestr,"",0);
2746 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2748 /* If it looks like the start of a BOM or raw UTF-16,
2749 * check if it in fact is. */
2755 #ifdef PERLIO_IS_STDIO
2756 # ifdef __GNU_LIBRARY__
2757 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2758 # define FTELL_FOR_PIPE_IS_BROKEN
2762 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2763 # define FTELL_FOR_PIPE_IS_BROKEN
2768 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2769 /* This loses the possibility to detect the bof
2770 * situation on perl -P when the libc5 is being used.
2771 * Workaround? Maybe attach some extra state to PL_rsfp?
2774 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2776 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2779 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2780 s = swallow_bom((U8*)s);
2784 /* Incest with pod. */
2785 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2786 sv_setpvn(PL_linestr, "", 0);
2787 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2788 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2789 PL_last_lop = PL_last_uni = Nullch;
2790 PL_doextract = FALSE;
2794 } while (PL_doextract);
2795 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2796 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2797 SV * const sv = NEWSV(85,0);
2799 sv_upgrade(sv, SVt_PVMG);
2800 sv_setsv(sv,PL_linestr);
2803 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2805 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2806 PL_last_lop = PL_last_uni = Nullch;
2807 if (CopLINE(PL_curcop) == 1) {
2808 while (s < PL_bufend && isSPACE(*s))
2810 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2814 if (*s == '#' && *(s+1) == '!')
2816 #ifdef ALTERNATE_SHEBANG
2818 static char const as[] = ALTERNATE_SHEBANG;
2819 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2820 d = s + (sizeof(as) - 1);
2822 #endif /* ALTERNATE_SHEBANG */
2831 while (*d && !isSPACE(*d))
2835 #ifdef ARG_ZERO_IS_SCRIPT
2836 if (ipathend > ipath) {
2838 * HP-UX (at least) sets argv[0] to the script name,
2839 * which makes $^X incorrect. And Digital UNIX and Linux,
2840 * at least, set argv[0] to the basename of the Perl
2841 * interpreter. So, having found "#!", we'll set it right.
2843 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2844 assert(SvPOK(x) || SvGMAGICAL(x));
2845 if (sv_eq(x, CopFILESV(PL_curcop))) {
2846 sv_setpvn(x, ipath, ipathend - ipath);
2852 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
2853 const char * const lstart = SvPV_const(x,llen);
2855 bstart += blen - llen;
2856 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2857 sv_setpvn(x, ipath, ipathend - ipath);
2862 TAINT_NOT; /* $^X is always tainted, but that's OK */
2864 #endif /* ARG_ZERO_IS_SCRIPT */
2869 d = instr(s,"perl -");
2871 d = instr(s,"perl");
2873 /* avoid getting into infinite loops when shebang
2874 * line contains "Perl" rather than "perl" */
2876 for (d = ipathend-4; d >= ipath; --d) {
2877 if ((*d == 'p' || *d == 'P')
2878 && !ibcmp(d, "perl", 4))
2888 #ifdef ALTERNATE_SHEBANG
2890 * If the ALTERNATE_SHEBANG on this system starts with a
2891 * character that can be part of a Perl expression, then if
2892 * we see it but not "perl", we're probably looking at the
2893 * start of Perl code, not a request to hand off to some
2894 * other interpreter. Similarly, if "perl" is there, but
2895 * not in the first 'word' of the line, we assume the line
2896 * contains the start of the Perl program.
2898 if (d && *s != '#') {
2899 const char *c = ipath;
2900 while (*c && !strchr("; \t\r\n\f\v#", *c))
2903 d = Nullch; /* "perl" not in first word; ignore */
2905 *s = '#'; /* Don't try to parse shebang line */
2907 #endif /* ALTERNATE_SHEBANG */
2908 #ifndef MACOS_TRADITIONAL
2913 !instr(s,"indir") &&
2914 instr(PL_origargv[0],"perl"))
2921 while (s < PL_bufend && isSPACE(*s))
2923 if (s < PL_bufend) {
2924 Newxz(newargv,PL_origargc+3,char*);
2926 while (s < PL_bufend && !isSPACE(*s))
2929 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2932 newargv = PL_origargv;
2935 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2937 Perl_croak(aTHX_ "Can't exec %s", ipath);
2941 const U32 oldpdb = PL_perldb;
2942 const bool oldn = PL_minus_n;
2943 const bool oldp = PL_minus_p;
2945 while (*d && !isSPACE(*d)) d++;
2946 while (SPACE_OR_TAB(*d)) d++;
2949 const bool switches_done = PL_doswitches;
2951 if (*d == 'M' || *d == 'm' || *d == 'C') {
2952 const char * const m = d;
2953 while (*d && !isSPACE(*d)) d++;
2954 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2957 d = moreswitches(d);
2959 if (PL_doswitches && !switches_done) {
2960 int argc = PL_origargc;
2961 char **argv = PL_origargv;
2964 } while (argc && argv[0][0] == '-' && argv[0][1]);
2965 init_argv_symbols(argc,argv);
2967 if ((PERLDB_LINE && !oldpdb) ||
2968 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2969 /* if we have already added "LINE: while (<>) {",
2970 we must not do it again */
2972 sv_setpvn(PL_linestr, "", 0);
2973 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2974 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2975 PL_last_lop = PL_last_uni = Nullch;
2976 PL_preambled = FALSE;
2978 (void)gv_fetchfile(PL_origfilename);
2981 if (PL_doswitches && !switches_done) {
2982 int argc = PL_origargc;
2983 char **argv = PL_origargv;
2986 } while (argc && argv[0][0] == '-' && argv[0][1]);
2987 init_argv_symbols(argc,argv);
2993 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2995 PL_lex_state = LEX_FORMLINE;
3000 #ifdef PERL_STRICT_CR
3001 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3003 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3005 case ' ': case '\t': case '\f': case 013:
3006 #ifdef MACOS_TRADITIONAL
3013 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3014 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3015 /* handle eval qq[#line 1 "foo"\n ...] */
3016 CopLINE_dec(PL_curcop);
3020 while (s < d && *s != '\n')
3024 else if (s > d) /* Found by Ilya: feed random input to Perl. */
3025 Perl_croak(aTHX_ "panic: input overflow");
3027 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3029 PL_lex_state = LEX_FORMLINE;
3039 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3046 while (s < PL_bufend && SPACE_OR_TAB(*s))
3049 if (strnEQ(s,"=>",2)) {
3050 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3051 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3052 "### Saw unary minus before =>, forcing word '%s'\n", s);
3054 OPERATOR('-'); /* unary minus */
3056 PL_last_uni = PL_oldbufptr;
3058 case 'r': ftst = OP_FTEREAD; break;
3059 case 'w': ftst = OP_FTEWRITE; break;
3060 case 'x': ftst = OP_FTEEXEC; break;
3061 case 'o': ftst = OP_FTEOWNED; break;
3062 case 'R': ftst = OP_FTRREAD; break;
3063 case 'W': ftst = OP_FTRWRITE; break;
3064 case 'X': ftst = OP_FTREXEC; break;
3065 case 'O': ftst = OP_FTROWNED; break;
3066 case 'e': ftst = OP_FTIS; break;
3067 case 'z': ftst = OP_FTZERO; break;
3068 case 's': ftst = OP_FTSIZE; break;
3069 case 'f': ftst = OP_FTFILE; break;
3070 case 'd': ftst = OP_FTDIR; break;
3071 case 'l': ftst = OP_FTLINK; break;
3072 case 'p': ftst = OP_FTPIPE; break;
3073 case 'S': ftst = OP_FTSOCK; break;
3074 case 'u': ftst = OP_FTSUID; break;
3075 case 'g': ftst = OP_FTSGID; break;
3076 case 'k': ftst = OP_FTSVTX; break;
3077 case 'b': ftst = OP_FTBLK; break;
3078 case 'c': ftst = OP_FTCHR; break;
3079 case 't': ftst = OP_FTTTY; break;
3080 case 'T': ftst = OP_FTTEXT; break;
3081 case 'B': ftst = OP_FTBINARY; break;
3082 case 'M': case 'A': case 'C':
3083 gv_fetchpv("\024",TRUE, SVt_PV);
3085 case 'M': ftst = OP_FTMTIME; break;
3086 case 'A': ftst = OP_FTATIME; break;
3087 case 'C': ftst = OP_FTCTIME; break;
3095 PL_last_lop_op = (OPCODE)ftst;
3096 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3097 "### Saw file test %c\n", (int)ftst);
3102 /* Assume it was a minus followed by a one-letter named
3103 * subroutine call (or a -bareword), then. */
3104 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3105 "### '-%c' looked like a file test but was not\n",
3114 if (PL_expect == XOPERATOR)
3119 else if (*s == '>') {
3122 if (isIDFIRST_lazy_if(s,UTF)) {
3123 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3131 if (PL_expect == XOPERATOR)
3134 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3136 OPERATOR('-'); /* unary minus */
3143 if (PL_expect == XOPERATOR)
3148 if (PL_expect == XOPERATOR)
3151 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3157 if (PL_expect != XOPERATOR) {
3158 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3159 PL_expect = XOPERATOR;
3160 force_ident(PL_tokenbuf, '*');
3173 if (PL_expect == XOPERATOR) {
3177 PL_tokenbuf[0] = '%';
3178 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3179 if (!PL_tokenbuf[1]) {
3182 PL_pending_ident = '%';
3201 switch (PL_expect) {
3204 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3206 PL_bufptr = s; /* update in case we back off */
3212 PL_expect = XTERMBLOCK;
3216 while (isIDFIRST_lazy_if(s,UTF)) {
3217 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3218 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3219 if (tmp < 0) tmp = -tmp;
3235 d = scan_str(d,TRUE,TRUE);
3237 /* MUST advance bufptr here to avoid bogus
3238 "at end of line" context messages from yyerror().
3240 PL_bufptr = s + len;
3241 yyerror("Unterminated attribute parameter in attribute list");
3244 return REPORT(0); /* EOF indicator */
3248 SV *sv = newSVpvn(s, len);
3249 sv_catsv(sv, PL_lex_stuff);
3250 attrs = append_elem(OP_LIST, attrs,
3251 newSVOP(OP_CONST, 0, sv));
3252 SvREFCNT_dec(PL_lex_stuff);
3253 PL_lex_stuff = Nullsv;
3256 if (len == 6 && strnEQ(s, "unique", len)) {
3257 if (PL_in_my == KEY_our)
3259 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3261 ; /* skip to avoid loading attributes.pm */
3264 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3267 /* NOTE: any CV attrs applied here need to be part of
3268 the CVf_BUILTIN_ATTRS define in cv.h! */
3269 else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3270 CvLVALUE_on(PL_compcv);
3271 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3272 CvLOCKED_on(PL_compcv);
3273 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3274 CvMETHOD_on(PL_compcv);
3275 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3276 CvASSERTION_on(PL_compcv);
3277 /* After we've set the flags, it could be argued that
3278 we don't need to do the attributes.pm-based setting
3279 process, and shouldn't bother appending recognized
3280 flags. To experiment with that, uncomment the
3281 following "else". (Note that's already been
3282 uncommented. That keeps the above-applied built-in
3283 attributes from being intercepted (and possibly
3284 rejected) by a package's attribute routines, but is
3285 justified by the performance win for the common case
3286 of applying only built-in attributes.) */
3288 attrs = append_elem(OP_LIST, attrs,
3289 newSVOP(OP_CONST, 0,
3293 if (*s == ':' && s[1] != ':')
3296 break; /* require real whitespace or :'s */
3298 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3299 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3300 const char q = ((*s == '\'') ? '"' : '\'');
3301 /* If here for an expression, and parsed no attrs, back off. */
3302 if (tmp == '=' && !attrs) {
3306 /* MUST advance bufptr here to avoid bogus "at end of line"
3307 context messages from yyerror().
3311 yyerror("Unterminated attribute list");
3313 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3321 PL_nextval[PL_nexttoke].opval = attrs;
3329 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3330 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3347 if (PL_lex_brackets <= 0)
3348 yyerror("Unmatched right square bracket");
3351 if (PL_lex_state == LEX_INTERPNORMAL) {
3352 if (PL_lex_brackets == 0) {
3353 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3354 PL_lex_state = LEX_INTERPEND;
3361 if (PL_lex_brackets > 100) {
3362 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3364 switch (PL_expect) {
3366 if (PL_lex_formbrack) {
3370 if (PL_oldoldbufptr == PL_last_lop)
3371 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3373 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3374 OPERATOR(HASHBRACK);
3376 while (s < PL_bufend && SPACE_OR_TAB(*s))
3379 PL_tokenbuf[0] = '\0';
3380 if (d < PL_bufend && *d == '-') {
3381 PL_tokenbuf[0] = '-';
3383 while (d < PL_bufend && SPACE_OR_TAB(*d))
3386 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3387 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3389 while (d < PL_bufend && SPACE_OR_TAB(*d))
3392 const char minus = (PL_tokenbuf[0] == '-');
3393 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3401 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3406 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3411 if (PL_oldoldbufptr == PL_last_lop)
3412 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3414 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3417 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3419 /* This hack is to get the ${} in the message. */
3421 yyerror("syntax error");
3424 OPERATOR(HASHBRACK);
3426 /* This hack serves to disambiguate a pair of curlies
3427 * as being a block or an anon hash. Normally, expectation
3428 * determines that, but in cases where we're not in a
3429 * position to expect anything in particular (like inside
3430 * eval"") we have to resolve the ambiguity. This code
3431 * covers the case where the first term in the curlies is a
3432 * quoted string. Most other cases need to be explicitly
3433 * disambiguated by prepending a "+" before the opening
3434 * curly in order to force resolution as an anon hash.
3436 * XXX should probably propagate the outer expectation
3437 * into eval"" to rely less on this hack, but that could
3438 * potentially break current behavior of eval"".
3442 if (*s == '\'' || *s == '"' || *s == '`') {
3443 /* common case: get past first string, handling escapes */
3444 for (t++; t < PL_bufend && *t != *s;)
3445 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3449 else if (*s == 'q') {
3452 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3455 /* skip q//-like construct */
3457 char open, close, term;
3460 while (t < PL_bufend && isSPACE(*t))
3462 /* check for q => */
3463 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3464 OPERATOR(HASHBRACK);
3468 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3472 for (t++; t < PL_bufend; t++) {
3473 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3475 else if (*t == open)
3479 for (t++; t < PL_bufend; t++) {
3480 if (*t == '\\' && t+1 < PL_bufend)
3482 else if (*t == close && --brackets <= 0)
3484 else if (*t == open)
3491 /* skip plain q word */
3492 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3495 else if (isALNUM_lazy_if(t,UTF)) {
3497 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3500 while (t < PL_bufend && isSPACE(*t))
3502 /* if comma follows first term, call it an anon hash */
3503 /* XXX it could be a comma expression with loop modifiers */
3504 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3505 || (*t == '=' && t[1] == '>')))
3506 OPERATOR(HASHBRACK);
3507 if (PL_expect == XREF)
3510 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3516 yylval.ival = CopLINE(PL_curcop);
3517 if (isSPACE(*s) || *s == '#')
3518 PL_copline = NOLINE; /* invalidate current command line number */
3523 if (PL_lex_brackets <= 0)
3524 yyerror("Unmatched right curly bracket");
3526 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3527 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3528 PL_lex_formbrack = 0;
3529 if (PL_lex_state == LEX_INTERPNORMAL) {
3530 if (PL_lex_brackets == 0) {
3531 if (PL_expect & XFAKEBRACK) {
3532 PL_expect &= XENUMMASK;
3533 PL_lex_state = LEX_INTERPEND;
3535 return yylex(); /* ignore fake brackets */
3537 if (*s == '-' && s[1] == '>')
3538 PL_lex_state = LEX_INTERPENDMAYBE;
3539 else if (*s != '[' && *s != '{')
3540 PL_lex_state = LEX_INTERPEND;
3543 if (PL_expect & XFAKEBRACK) {
3544 PL_expect &= XENUMMASK;
3546 return yylex(); /* ignore fake brackets */
3556 if (PL_expect == XOPERATOR) {
3557 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
3558 && isIDFIRST_lazy_if(s,UTF))
3560 CopLINE_dec(PL_curcop);
3561 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3562 CopLINE_inc(PL_curcop);
3567 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3569 PL_expect = XOPERATOR;
3570 force_ident(PL_tokenbuf, '&');
3574 yylval.ival = (OPpENTERSUB_AMPER<<8);
3593 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp))
3594 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3596 if (PL_expect == XSTATE && isALPHA(tmp) &&
3597 (s == PL_linestart+1 || s[-2] == '\n') )
3599 if (PL_in_eval && !PL_rsfp) {
3604 if (strnEQ(s,"=cut",4)) {
3618 PL_doextract = TRUE;
3621 if (PL_lex_brackets < PL_lex_formbrack) {
3623 #ifdef PERL_STRICT_CR
3624 for (t = s; SPACE_OR_TAB(*t); t++) ;
3626 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3628 if (*t == '\n' || *t == '#') {
3640 /* was this !=~ where !~ was meant?
3641 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3643 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3644 const char *t = s+1;
3646 while (t < PL_bufend && isSPACE(*t))
3649 if (*t == '/' || *t == '?' ||
3650 ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3651 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3652 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3653 "!=~ should be !~");
3662 if (PL_expect != XOPERATOR) {
3663 if (s[1] != '<' && !strchr(s,'>'))
3666 s = scan_heredoc(s);
3668 s = scan_inputsymbol(s);
3669 TERM(sublex_start());
3674 SHop(OP_LEFT_SHIFT);
3688 SHop(OP_RIGHT_SHIFT);
3697 if (PL_expect == XOPERATOR) {
3698 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3701 return REPORT(','); /* grandfather non-comma-format format */
3705 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3706 PL_tokenbuf[0] = '@';
3707 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3708 sizeof PL_tokenbuf - 1, FALSE);
3709 if (PL_expect == XOPERATOR)
3710 no_op("Array length", s);
3711 if (!PL_tokenbuf[1])
3713 PL_expect = XOPERATOR;
3714 PL_pending_ident = '#';
3718 PL_tokenbuf[0] = '$';
3719 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3720 sizeof PL_tokenbuf - 1, FALSE);
3721 if (PL_expect == XOPERATOR)
3723 if (!PL_tokenbuf[1]) {
3725 yyerror("Final $ should be \\$ or $name");
3729 /* This kludge not intended to be bulletproof. */
3730 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3731 yylval.opval = newSVOP(OP_CONST, 0,
3732 newSViv(PL_compiling.cop_arybase));
3733 yylval.opval->op_private = OPpCONST_ARYBASE;
3739 if (PL_lex_state == LEX_NORMAL)
3742 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3744 PL_tokenbuf[0] = '@';
3745 if (ckWARN(WARN_SYNTAX)) {
3748 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3751 PL_bufptr = skipspace(PL_bufptr);
3752 while (t < PL_bufend && *t != ']')
3754 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3755 "Multidimensional syntax %.*s not supported",
3756 (t - PL_bufptr) + 1, PL_bufptr);
3760 else if (*s == '{') {
3762 PL_tokenbuf[0] = '%';
3763 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
3764 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
3766 char tmpbuf[sizeof PL_tokenbuf];
3767 for (t++; isSPACE(*t); t++) ;
3768 if (isIDFIRST_lazy_if(t,UTF)) {
3770 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3771 for (; isSPACE(*t); t++) ;
3772 if (*t == ';' && get_cv(tmpbuf, FALSE))
3773 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3774 "You need to quote \"%s\"", tmpbuf);
3780 PL_expect = XOPERATOR;
3781 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3782 const bool islop = (PL_last_lop == PL_oldoldbufptr);
3783 if (!islop || PL_last_lop_op == OP_GREPSTART)
3784 PL_expect = XOPERATOR;
3785 else if (strchr("$@\"'`q", *s))
3786 PL_expect = XTERM; /* e.g. print $fh "foo" */
3787 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3788 PL_expect = XTERM; /* e.g. print $fh &sub */
3789 else if (isIDFIRST_lazy_if(s,UTF)) {
3790 char tmpbuf[sizeof PL_tokenbuf];
3791 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3792 if ((tmp = keyword(tmpbuf, len))) {
3793 /* binary operators exclude handle interpretations */
3805 PL_expect = XTERM; /* e.g. print $fh length() */
3810 PL_expect = XTERM; /* e.g. print $fh subr() */
3813 else if (isDIGIT(*s))
3814 PL_expect = XTERM; /* e.g. print $fh 3 */
3815 else if (*s == '.' && isDIGIT(s[1]))
3816 PL_expect = XTERM; /* e.g. print $fh .3 */
3817 else if ((*s == '?' || *s == '-' || *s == '+')
3818 && !isSPACE(s[1]) && s[1] != '=')
3819 PL_expect = XTERM; /* e.g. print $fh -1 */
3820 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3821 PL_expect = XTERM; /* e.g. print $fh /.../
3822 XXX except DORDOR operator */
3823 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3824 PL_expect = XTERM; /* print $fh <<"EOF" */
3826 PL_pending_ident = '$';
3830 if (PL_expect == XOPERATOR)
3832 PL_tokenbuf[0] = '@';
3833 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3834 if (!PL_tokenbuf[1]) {
3837 if (PL_lex_state == LEX_NORMAL)
3839 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3841 PL_tokenbuf[0] = '%';
3843 /* Warn about @ where they meant $. */
3844 if (*s == '[' || *s == '{') {
3845 if (ckWARN(WARN_SYNTAX)) {
3846 const char *t = s + 1;
3847 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3849 if (*t == '}' || *t == ']') {
3851 PL_bufptr = skipspace(PL_bufptr);
3852 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3853 "Scalar value %.*s better written as $%.*s",
3854 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3859 PL_pending_ident = '@';
3862 case '/': /* may be division, defined-or, or pattern */
3863 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3867 case '?': /* may either be conditional or pattern */
3868 if(PL_expect == XOPERATOR) {
3876 /* A // operator. */
3886 /* Disable warning on "study /blah/" */
3887 if (PL_oldoldbufptr == PL_last_uni
3888 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3889 || memNE(PL_last_uni, "study", 5)
3890 || isALNUM_lazy_if(PL_last_uni+5,UTF)
3893 s = scan_pat(s,OP_MATCH);
3894 TERM(sublex_start());
3898 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3899 #ifdef PERL_STRICT_CR
3902 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3904 && (s == PL_linestart || s[-1] == '\n') )
3906 PL_lex_formbrack = 0;
3910 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3916 yylval.ival = OPf_SPECIAL;
3922 if (PL_expect != XOPERATOR)
3927 case '0': case '1': case '2': case '3': case '4':
3928 case '5': case '6': case '7': case '8': case '9':
3929 s = scan_num(s, &yylval);
3930 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3931 "### Saw number in '%s'\n", s);
3933 if (PL_expect == XOPERATOR)
3938 s = scan_str(s,FALSE,FALSE);
3939 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3940 "### Saw string before '%s'\n", s);
3942 if (PL_expect == XOPERATOR) {
3943 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3946 return REPORT(','); /* grandfather non-comma-format format */
3952 missingterm((char*)0);
3953 yylval.ival = OP_CONST;
3954 TERM(sublex_start());
3957 s = scan_str(s,FALSE,FALSE);
3958 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3959 "### Saw string before '%s'\n", s);
3961 if (PL_expect == XOPERATOR) {
3962 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3965 return REPORT(','); /* grandfather non-comma-format format */
3971 missingterm((char*)0);
3972 yylval.ival = OP_CONST;
3973 /* FIXME. I think that this can be const if char *d is replaced by
3974 more localised variables. */
3975 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3976 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3977 yylval.ival = OP_STRINGIFY;
3981 TERM(sublex_start());
3984 s = scan_str(s,FALSE,FALSE);
3985 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3986 "### Saw backtick string before '%s'\n", s);
3988 if (PL_expect == XOPERATOR)
3989 no_op("Backticks",s);
3991 missingterm((char*)0);
3992 yylval.ival = OP_BACKTICK;
3994 TERM(sublex_start());
3998 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
3999 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
4001 if (PL_expect == XOPERATOR)
4002 no_op("Backslash",s);
4006 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
4007 char *start = s + 2;
4008 while (isDIGIT(*start) || *start == '_')
4010 if (*start == '.' && isDIGIT(start[1])) {
4011 s = scan_num(s, &yylval);
4014 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
4015 else if (!isALPHA(*start) && (PL_expect == XTERM
4016 || PL_expect == XREF || PL_expect == XSTATE
4017 || PL_expect == XTERMORDORDOR)) {
4018 const char c = *start;
4021 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
4024 s = scan_num(s, &yylval);
4031 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
4071 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4073 /* Some keywords can be followed by any delimiter, including ':' */
4074 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4075 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4076 (PL_tokenbuf[0] == 'q' &&
4077 strchr("qwxr", PL_tokenbuf[1])))));
4079 /* x::* is just a word, unless x is "CORE" */
4080 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4084 while (d < PL_bufend && isSPACE(*d))
4085 d++; /* no comments skipped here, or s### is misparsed */
4087 /* Is this a label? */
4088 if (!tmp && PL_expect == XSTATE
4089 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4091 yylval.pval = savepv(PL_tokenbuf);
4096 /* Check for keywords */
4097 tmp = keyword(PL_tokenbuf, len);
4099 /* Is this a word before a => operator? */
4100 if (*d == '=' && d[1] == '>') {
4103 = (OP*)newSVOP(OP_CONST, 0,
4104 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4105 yylval.opval->op_private = OPpCONST_BARE;
4109 if (tmp < 0) { /* second-class keyword? */
4110 GV *ogv = Nullgv; /* override (winner) */
4111 GV *hgv = Nullgv; /* hidden (loser) */
4112 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4114 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4117 if (GvIMPORTED_CV(gv))
4119 else if (! CvMETHOD(cv))
4123 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4124 (gv = *gvp) != (GV*)&PL_sv_undef &&
4125 GvCVu(gv) && GvIMPORTED_CV(gv))
4132 tmp = 0; /* overridden by import or by GLOBAL */
4135 && -tmp==KEY_lock /* XXX generalizable kludge */
4137 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4139 tmp = 0; /* any sub overrides "weak" keyword */
4144 && PL_expect != XOPERATOR
4145 && PL_expect != XTERMORDORDOR)
4147 /* any sub overrides the "err" keyword, except when really an
4148 * operator is expected */
4151 else { /* no override */
4153 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4154 Perl_warner(aTHX_ packWARN(WARN_MISC),
4155 "dump() better written as CORE::dump()");
4159 if (hgv && tmp != KEY_x && tmp != KEY_CORE
4160 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
4161 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4162 "Ambiguous call resolved as CORE::%s(), %s",
4163 GvENAME(hgv), "qualify as such or use &");
4170 default: /* not a keyword */
4174 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4176 /* Get the rest if it looks like a package qualifier */
4178 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4180 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4183 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4184 *s == '\'' ? "'" : "::");
4189 if (PL_expect == XOPERATOR) {
4190 if (PL_bufptr == PL_linestart) {
4191 CopLINE_dec(PL_curcop);
4192 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4193 CopLINE_inc(PL_curcop);
4196 no_op("Bareword",s);
4199 /* Look for a subroutine with this name in current package,
4200 unless name is "Foo::", in which case Foo is a bearword
4201 (and a package name). */
4204 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4206 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4207 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4208 "Bareword \"%s\" refers to nonexistent package",
4211 PL_tokenbuf[len] = '\0';
4218 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4221 /* if we saw a global override before, get the right name */
4224 sv = newSVpvn("CORE::GLOBAL::",14);
4225 sv_catpv(sv,PL_tokenbuf);
4228 /* If len is 0, newSVpv does strlen(), which is correct.
4229 If len is non-zero, then it will be the true length,
4230 and so the scalar will be created correctly. */
4231 sv = newSVpv(PL_tokenbuf,len);
4234 /* Presume this is going to be a bareword of some sort. */
4237 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4238 yylval.opval->op_private = OPpCONST_BARE;
4239 /* UTF-8 package name? */
4240 if (UTF && !IN_BYTES &&
4241 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
4244 /* And if "Foo::", then that's what it certainly is. */
4249 /* See if it's the indirect object for a list operator. */
4251 if (PL_oldoldbufptr &&
4252 PL_oldoldbufptr < PL_bufptr &&
4253 (PL_oldoldbufptr == PL_last_lop
4254 || PL_oldoldbufptr == PL_last_uni) &&
4255 /* NO SKIPSPACE BEFORE HERE! */
4256 (PL_expect == XREF ||
4257 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4259 bool immediate_paren = *s == '(';
4261 /* (Now we can afford to cross potential line boundary.) */
4264 /* Two barewords in a row may indicate method call. */
4266 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4269 /* If not a declared subroutine, it's an indirect object. */
4270 /* (But it's an indir obj regardless for sort.) */
4272 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4273 ((!gv || !GvCVu(gv)) &&
4274 (PL_last_lop_op != OP_MAPSTART &&
4275 PL_last_lop_op != OP_GREPSTART))))
4277 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4282 PL_expect = XOPERATOR;
4285 /* Is this a word before a => operator? */
4286 if (*s == '=' && s[1] == '>' && !pkgname) {
4288 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4289 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4290 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4294 /* If followed by a paren, it's certainly a subroutine. */
4297 if (gv && GvCVu(gv)) {
4298 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4299 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4304 PL_nextval[PL_nexttoke].opval = yylval.opval;
4305 PL_expect = XOPERATOR;
4311 /* If followed by var or block, call it a method (unless sub) */
4313 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4314 PL_last_lop = PL_oldbufptr;
4315 PL_last_lop_op = OP_METHOD;
4319 /* If followed by a bareword, see if it looks like indir obj. */
4322 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4323 && (tmp = intuit_method(s,gv)))
4326 /* Not a method, so call it a subroutine (if defined) */
4328 if (gv && GvCVu(gv)) {
4330 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4331 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4332 "Ambiguous use of -%s resolved as -&%s()",
4333 PL_tokenbuf, PL_tokenbuf);
4334 /* Check for a constant sub */
4336 if ((sv = cv_const_sv(cv))) {
4338 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4339 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4340 yylval.opval->op_private = 0;
4344 /* Resolve to GV now. */
4345 op_free(yylval.opval);
4346 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4347 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4348 PL_last_lop = PL_oldbufptr;
4349 PL_last_lop_op = OP_ENTERSUB;
4350 /* Is there a prototype? */
4353 const char *proto = SvPV_const((SV*)cv, len);
4356 if (*proto == '$' && proto[1] == '\0')
4358 while (*proto == ';')
4360 if (*proto == '&' && *s == '{') {
4361 sv_setpv(PL_subname, PL_curstash ?
4362 "__ANON__" : "__ANON__::__ANON__");
4366 PL_nextval[PL_nexttoke].opval = yylval.opval;
4372 /* Call it a bare word */
4374 if (PL_hints & HINT_STRICT_SUBS)
4375 yylval.opval->op_private |= OPpCONST_STRICT;
4378 if (lastchar != '-') {
4379 if (ckWARN(WARN_RESERVED)) {
4380 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4381 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4382 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4389 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4390 && ckWARN_d(WARN_AMBIGUOUS)) {
4391 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4392 "Operator or semicolon missing before %c%s",
4393 lastchar, PL_tokenbuf);
4394 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4395 "Ambiguous use of %c resolved as operator %c",
4396 lastchar, lastchar);
4402 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4403 newSVpv(CopFILE(PL_curcop),0));
4407 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4408 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4411 case KEY___PACKAGE__:
4412 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4414 ? newSVhek(HvNAME_HEK(PL_curstash))
4421 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4422 const char *pname = "main";
4423 if (PL_tokenbuf[2] == 'D')
4424 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
4425 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4428 GvIOp(gv) = newIO();
4429 IoIFP(GvIOp(gv)) = PL_rsfp;
4430 #if defined(HAS_FCNTL) && defined(F_SETFD)
4432 const int fd = PerlIO_fileno(PL_rsfp);
4433 fcntl(fd,F_SETFD,fd >= 3);
4436 /* Mark this internal pseudo-handle as clean */
4437 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4439 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4440 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4441 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4443 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4444 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4445 /* if the script was opened in binmode, we need to revert
4446 * it to text mode for compatibility; but only iff it has CRs
4447 * XXX this is a questionable hack at best. */
4448 if (PL_bufend-PL_bufptr > 2
4449 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4452 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4453 loc = PerlIO_tell(PL_rsfp);
4454 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4457 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4459 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4460 #endif /* NETWARE */
4461 #ifdef PERLIO_IS_STDIO /* really? */
4462 # if defined(__BORLANDC__)
4463 /* XXX see note in do_binmode() */
4464 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4468 PerlIO_seek(PL_rsfp, loc, 0);
4472 #ifdef PERLIO_LAYERS
4475 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4476 else if (PL_encoding) {
4483 XPUSHs(PL_encoding);
4485 call_method("name", G_SCALAR);
4489 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4490 Perl_form(aTHX_ ":encoding(%"SVf")",
4508 if (PL_expect == XSTATE) {
4515 if (*s == ':' && s[1] == ':') {
4518 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4519 if (!(tmp = keyword(PL_tokenbuf, len)))
4520 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4523 else if (tmp == KEY_require)
4524 /* that's a way to remember we saw "CORE::" */
4525 orig_keyword = KEY_require;
4537 LOP(OP_ACCEPT,XTERM);
4543 LOP(OP_ATAN2,XTERM);
4549 LOP(OP_BINMODE,XTERM);
4552 LOP(OP_BLESS,XTERM);
4561 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4578 if (!PL_cryptseen) {
4579 PL_cryptseen = TRUE;
4583 LOP(OP_CRYPT,XTERM);
4586 LOP(OP_CHMOD,XTERM);
4589 LOP(OP_CHOWN,XTERM);
4592 LOP(OP_CONNECT,XTERM);
4608 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4612 PL_hints |= HINT_BLOCK_SCOPE;
4622 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4623 LOP(OP_DBMOPEN,XTERM);
4629 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4636 yylval.ival = CopLINE(PL_curcop);
4650 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4651 UNIBRACK(OP_ENTEREVAL);
4669 case KEY_endhostent:
4675 case KEY_endservent:
4678 case KEY_endprotoent:
4689 yylval.ival = CopLINE(PL_curcop);
4691 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4693 if ((PL_bufend - p) >= 3 &&
4694 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4696 else if ((PL_bufend - p) >= 4 &&
4697 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4700 if (isIDFIRST_lazy_if(p,UTF)) {
4701 p = scan_ident(p, PL_bufend,
4702 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4706 Perl_croak(aTHX_ "Missing $ on loop variable");
4711 LOP(OP_FORMLINE,XTERM);
4717 LOP(OP_FCNTL,XTERM);
4723 LOP(OP_FLOCK,XTERM);
4732 LOP(OP_GREPSTART, XREF);
4735 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4750 case KEY_getpriority:
4751 LOP(OP_GETPRIORITY,XTERM);
4753 case KEY_getprotobyname:
4756 case KEY_getprotobynumber:
4757 LOP(OP_GPBYNUMBER,XTERM);
4759 case KEY_getprotoent:
4771 case KEY_getpeername:
4772 UNI(OP_GETPEERNAME);
4774 case KEY_gethostbyname:
4777 case KEY_gethostbyaddr:
4778 LOP(OP_GHBYADDR,XTERM);
4780 case KEY_gethostent:
4783 case KEY_getnetbyname:
4786 case KEY_getnetbyaddr:
4787 LOP(OP_GNBYADDR,XTERM);
4792 case KEY_getservbyname:
4793 LOP(OP_GSBYNAME,XTERM);
4795 case KEY_getservbyport:
4796 LOP(OP_GSBYPORT,XTERM);
4798 case KEY_getservent:
4801 case KEY_getsockname:
4802 UNI(OP_GETSOCKNAME);
4804 case KEY_getsockopt:
4805 LOP(OP_GSOCKOPT,XTERM);
4827 yylval.ival = CopLINE(PL_curcop);
4831 LOP(OP_INDEX,XTERM);
4837 LOP(OP_IOCTL,XTERM);
4849 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4881 LOP(OP_LISTEN,XTERM);
4890 s = scan_pat(s,OP_MATCH);
4891 TERM(sublex_start());
4894 LOP(OP_MAPSTART, XREF);
4897 LOP(OP_MKDIR,XTERM);
4900 LOP(OP_MSGCTL,XTERM);
4903 LOP(OP_MSGGET,XTERM);
4906 LOP(OP_MSGRCV,XTERM);
4909 LOP(OP_MSGSND,XTERM);
4915 if (isIDFIRST_lazy_if(s,UTF)) {
4916 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4917 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4919 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4920 if (!PL_in_my_stash) {
4923 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4931 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4938 s = tokenize_use(0, s);
4942 if (*s == '(' || (s = skipspace(s), *s == '('))
4949 if (isIDFIRST_lazy_if(s,UTF)) {
4951 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4952 for (t=d; *t && isSPACE(*t); t++) ;
4953 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4955 && !(t[0] == '=' && t[1] == '>')
4957 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4958 "Precedence problem: open %.*s should be open(%.*s)",
4959 d - s, s, d - s, s);
4965 yylval.ival = OP_OR;
4975 LOP(OP_OPEN_DIR,XTERM);
4978 checkcomma(s,PL_tokenbuf,"filehandle");
4982 checkcomma(s,PL_tokenbuf,"filehandle");
5001 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5005 LOP(OP_PIPE_OP,XTERM);
5008 s = scan_str(s,FALSE,FALSE);
5010 missingterm((char*)0);
5011 yylval.ival = OP_CONST;
5012 TERM(sublex_start());
5018 s = scan_str(s,FALSE,FALSE);
5020 missingterm((char*)0);
5021 PL_expect = XOPERATOR;
5023 if (SvCUR(PL_lex_stuff)) {
5026 d = SvPV_force(PL_lex_stuff, len);
5029 for (; isSPACE(*d) && len; --len, ++d) ;
5032 if (!warned && ckWARN(WARN_QW)) {
5033 for (; !isSPACE(*d) && len; --len, ++d) {
5035 Perl_warner(aTHX_ packWARN(WARN_QW),
5036 "Possible attempt to separate words with commas");
5039 else if (*d == '#') {
5040 Perl_warner(aTHX_ packWARN(WARN_QW),
5041 "Possible attempt to put comments in qw() list");
5047 for (; !isSPACE(*d) && len; --len, ++d) ;
5049 sv = newSVpvn(b, d-b);
5050 if (DO_UTF8(PL_lex_stuff))
5052 words = append_elem(OP_LIST, words,
5053 newSVOP(OP_CONST, 0, tokeq(sv)));
5057 PL_nextval[PL_nexttoke].opval = words;
5062 SvREFCNT_dec(PL_lex_stuff);
5063 PL_lex_stuff = Nullsv;
5069 s = scan_str(s,FALSE,FALSE);
5071 missingterm((char*)0);
5072 yylval.ival = OP_STRINGIFY;
5073 if (SvIVX(PL_lex_stuff) == '\'')
5074 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
5075 TERM(sublex_start());
5078 s = scan_pat(s,OP_QR);
5079 TERM(sublex_start());
5082 s = scan_str(s,FALSE,FALSE);
5084 missingterm((char*)0);
5085 yylval.ival = OP_BACKTICK;
5087 TERM(sublex_start());
5095 s = force_version(s, FALSE);
5097 else if (*s != 'v' || !isDIGIT(s[1])
5098 || (s = force_version(s, TRUE), *s == 'v'))
5100 *PL_tokenbuf = '\0';
5101 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5102 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5103 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5105 yyerror("<> should be quotes");
5107 if (orig_keyword == KEY_require) {
5115 PL_last_uni = PL_oldbufptr;
5116 PL_last_lop_op = OP_REQUIRE;
5118 return REPORT( (int)REQUIRE );
5124 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5128 LOP(OP_RENAME,XTERM);
5137 LOP(OP_RINDEX,XTERM);
5147 UNIDOR(OP_READLINE);
5160 LOP(OP_REVERSE,XTERM);
5163 UNIDOR(OP_READLINK);
5171 TERM(sublex_start());
5173 TOKEN(1); /* force error */
5182 LOP(OP_SELECT,XTERM);
5188 LOP(OP_SEMCTL,XTERM);
5191 LOP(OP_SEMGET,XTERM);
5194 LOP(OP_SEMOP,XTERM);
5200 LOP(OP_SETPGRP,XTERM);
5202 case KEY_setpriority:
5203 LOP(OP_SETPRIORITY,XTERM);
5205 case KEY_sethostent:
5211 case KEY_setservent:
5214 case KEY_setprotoent:
5224 LOP(OP_SEEKDIR,XTERM);
5226 case KEY_setsockopt:
5227 LOP(OP_SSOCKOPT,XTERM);
5233 LOP(OP_SHMCTL,XTERM);
5236 LOP(OP_SHMGET,XTERM);
5239 LOP(OP_SHMREAD,XTERM);
5242 LOP(OP_SHMWRITE,XTERM);
5245 LOP(OP_SHUTDOWN,XTERM);
5254 LOP(OP_SOCKET,XTERM);
5256 case KEY_socketpair:
5257 LOP(OP_SOCKPAIR,XTERM);
5260 checkcomma(s,PL_tokenbuf,"subroutine name");
5262 if (*s == ';' || *s == ')') /* probably a close */
5263 Perl_croak(aTHX_ "sort is now a reserved word");
5265 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5269 LOP(OP_SPLIT,XTERM);
5272 LOP(OP_SPRINTF,XTERM);
5275 LOP(OP_SPLICE,XTERM);
5290 LOP(OP_SUBSTR,XTERM);
5296 char tmpbuf[sizeof PL_tokenbuf];
5297 SSize_t tboffset = 0;
5298 expectation attrful;
5299 bool have_name, have_proto, bad_proto;
5300 const int key = tmp;
5304 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5305 (*s == ':' && s[1] == ':'))
5308 attrful = XATTRBLOCK;
5309 /* remember buffer pos'n for later force_word */
5310 tboffset = s - PL_oldbufptr;
5311 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5312 if (strchr(tmpbuf, ':'))
5313 sv_setpv(PL_subname, tmpbuf);
5315 sv_setsv(PL_subname,PL_curstname);
5316 sv_catpvn(PL_subname,"::",2);
5317 sv_catpvn(PL_subname,tmpbuf,len);
5324 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5325 PL_expect = XTERMBLOCK;
5326 attrful = XATTRTERM;
5327 sv_setpvn(PL_subname,"?",1);
5331 if (key == KEY_format) {
5333 PL_lex_formbrack = PL_lex_brackets + 1;
5335 (void) force_word(PL_oldbufptr + tboffset, WORD,
5340 /* Look for a prototype */
5344 s = scan_str(s,FALSE,FALSE);
5346 Perl_croak(aTHX_ "Prototype not terminated");
5347 /* strip spaces and check for bad characters */
5348 d = SvPVX(PL_lex_stuff);
5351 for (p = d; *p; ++p) {
5354 if (!strchr("$@%*;[]&\\", *p))
5359 if (bad_proto && ckWARN(WARN_SYNTAX))
5360 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5361 "Illegal character in prototype for %"SVf" : %s",
5363 SvCUR_set(PL_lex_stuff, tmp);
5371 if (*s == ':' && s[1] != ':')
5372 PL_expect = attrful;
5373 else if (*s != '{' && key == KEY_sub) {
5375 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5377 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5381 PL_nextval[PL_nexttoke].opval =
5382 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5383 PL_lex_stuff = Nullsv;
5387 sv_setpv(PL_subname,
5388 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5391 (void) force_word(PL_oldbufptr + tboffset, WORD,
5400 LOP(OP_SYSTEM,XREF);
5403 LOP(OP_SYMLINK,XTERM);
5406 LOP(OP_SYSCALL,XTERM);
5409 LOP(OP_SYSOPEN,XTERM);
5412 LOP(OP_SYSSEEK,XTERM);
5415 LOP(OP_SYSREAD,XTERM);
5418 LOP(OP_SYSWRITE,XTERM);
5422 TERM(sublex_start());
5443 LOP(OP_TRUNCATE,XTERM);
5455 yylval.ival = CopLINE(PL_curcop);
5459 yylval.ival = CopLINE(PL_curcop);
5463 LOP(OP_UNLINK,XTERM);
5469 LOP(OP_UNPACK,XTERM);
5472 LOP(OP_UTIME,XTERM);
5478 LOP(OP_UNSHIFT,XTERM);
5481 s = tokenize_use(1, s);
5491 yylval.ival = CopLINE(PL_curcop);
5495 PL_hints |= HINT_BLOCK_SCOPE;
5502 LOP(OP_WAITPID,XTERM);
5511 ctl_l[0] = toCTRL('L');
5513 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5516 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5521 if (PL_expect == XOPERATOR)
5527 yylval.ival = OP_XOR;
5532 TERM(sublex_start());
5537 #pragma segment Main
5541 S_pending_ident(pTHX)
5544 register I32 tmp = 0;
5545 /* pit holds the identifier we read and pending_ident is reset */
5546 char pit = PL_pending_ident;
5547 PL_pending_ident = 0;
5549 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5550 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5552 /* if we're in a my(), we can't allow dynamics here.
5553 $foo'bar has already been turned into $foo::bar, so
5554 just check for colons.
5556 if it's a legal name, the OP is a PADANY.
5559 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5560 if (strchr(PL_tokenbuf,':'))
5561 yyerror(Perl_form(aTHX_ "No package name allowed for "
5562 "variable %s in \"our\"",
5564 tmp = allocmy(PL_tokenbuf);
5567 if (strchr(PL_tokenbuf,':'))
5568 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5570 yylval.opval = newOP(OP_PADANY, 0);
5571 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5577 build the ops for accesses to a my() variable.
5579 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5580 then used in a comparison. This catches most, but not
5581 all cases. For instance, it catches
5582 sort { my($a); $a <=> $b }
5584 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5585 (although why you'd do that is anyone's guess).
5588 if (!strchr(PL_tokenbuf,':')) {
5590 tmp = pad_findmy(PL_tokenbuf);
5591 if (tmp != NOT_IN_PAD) {
5592 /* might be an "our" variable" */
5593 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5594 /* build ops for a bareword */
5595 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
5596 HEK * const stashname = HvNAME_HEK(stash);
5597 SV * const sym = newSVhek(stashname);
5598 sv_catpvn(sym, "::", 2);
5599 sv_catpv(sym, PL_tokenbuf+1);
5600 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5601 yylval.opval->op_private = OPpCONST_ENTERED;
5604 ? (GV_ADDMULTI | GV_ADDINEVAL)
5607 ((PL_tokenbuf[0] == '$') ? SVt_PV
5608 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5613 /* if it's a sort block and they're naming $a or $b */
5614 if (PL_last_lop_op == OP_SORT &&
5615 PL_tokenbuf[0] == '$' &&
5616 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5619 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5620 d < PL_bufend && *d != '\n';
5623 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5624 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5630 yylval.opval = newOP(OP_PADANY, 0);
5631 yylval.opval->op_targ = tmp;
5637 Whine if they've said @foo in a doublequoted string,
5638 and @foo isn't a variable we can find in the symbol
5641 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5642 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5643 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5644 && ckWARN(WARN_AMBIGUOUS))
5646 /* Downgraded from fatal to warning 20000522 mjd */
5647 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5648 "Possible unintended interpolation of %s in string",
5653 /* build ops for a bareword */
5654 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5655 yylval.opval->op_private = OPpCONST_ENTERED;
5656 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5657 ((PL_tokenbuf[0] == '$') ? SVt_PV
5658 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5664 * The following code was generated by perl_keyword.pl.
5668 Perl_keyword (pTHX_ const char *name, I32 len)
5672 case 1: /* 5 tokens of length 1 */
5704 case 2: /* 18 tokens of length 2 */
5850 case 3: /* 28 tokens of length 3 */
5854 if (name[1] == 'N' &&
5917 if (name[1] == 'i' &&
5957 if (name[1] == 'o' &&
5966 if (name[1] == 'e' &&
5975 if (name[1] == 'n' &&
5984 if (name[1] == 'o' &&
5993 if (name[1] == 'a' &&
6002 if (name[1] == 'o' &&
6064 if (name[1] == 'e' &&
6096 if (name[1] == 'i' &&
6105 if (name[1] == 's' &&
6114 if (name[1] == 'e' &&
6123 if (name[1] == 'o' &&
6135 case 4: /* 40 tokens of length 4 */
6139 if (name[1] == 'O' &&
6149 if (name[1] == 'N' &&
6159 if (name[1] == 'i' &&
6169 if (name[1] == 'h' &&
6179 if (name[1] == 'u' &&
6192 if (name[2] == 'c' &&
6201 if (name[2] == 's' &&
6210 if (name[2] == 'a' &&
6246 if (name[1] == 'o' &&
6259 if (name[2] == 't' &&
6268 if (name[2] == 'o' &&
6277 if (name[2] == 't' &&
6286 if (name[2] == 'e' &&
6299 if (name[1] == 'o' &&
6312 if (name[2] == 'y' &&
6321 if (name[2] == 'l' &&
6337 if (name[2] == 's' &&
6346 if (name[2] == 'n' &&
6355 if (name[2] == 'c' &&
6368 if (name[1] == 'e' &&
6378 if (name[1] == 'p' &&
6391 if (name[2] == 'c' &&
6400 if (name[2] == 'p' &&
6409 if (name[2] == 's' &&
6425 if (name[2] == 'n' &&
6495 if (name[2] == 'r' &&
6504 if (name[2] == 'r' &&
6513 if (name[2] == 'a' &&
6529 if (name[2] == 'l' &&
6596 case 5: /* 36 tokens of length 5 */
6600 if (name[1] == 'E' &&
6611 if (name[1] == 'H' &&
6625 if (name[2] == 'a' &&
6635 if (name[2] == 'a' &&
6649 if (name[1] == 'l' &&
6666 if (name[3] == 'i' &&
6675 if (name[3] == 'o' &&
6711 if (name[2] == 'o' &&
6721 if (name[2] == 'y' &&
6735 if (name[1] == 'l' &&
6749 if (name[2] == 'n' &&
6759 if (name[2] == 'o' &&
6776 if (name[2] == 'd' &&
6786 if (name[2] == 'c' &&
6803 if (name[2] == 'c' &&
6813 if (name[2] == 't' &&
6827 if (name[1] == 'k' &&
6838 if (name[1] == 'r' &&
6852 if (name[2] == 's' &&
6862 if (name[2] == 'd' &&
6879 if (name[2] == 'm' &&
6889 if (name[2] == 'i' &&
6899 if (name[2] == 'e' &&
6909 if (name[2] == 'l' &&
6919 if (name[2] == 'a' &&
6929 if (name[2] == 'u' &&
6943 if (name[1] == 'i' &&
6957 if (name[2] == 'a' &&
6970 if (name[3] == 'e' &&
7005 if (name[2] == 'i' &&
7022 if (name[2] == 'i' &&
7032 if (name[2] == 'i' &&
7049 case 6: /* 33 tokens of length 6 */
7053 if (name[1] == 'c' &&
7068 if (name[2] == 'l' &&
7079 if (name[2] == 'r' &&
7094 if (name[1] == 'e' &&
7109 if (name[2] == 's' &&
7114 if(ckWARN_d(WARN_SYNTAX))
7115 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7121 if (name[2] == 'i' &&
7139 if (name[2] == 'l' &&
7150 if (name[2] == 'r' &&
7165 if (name[1] == 'm' &&
7180 if (name[2] == 'n' &&
7191 if (name[2] == 's' &&
7206 if (name[1] == 's' &&
7212 if (name[4] == 't' &&
7221 if (name[4] == 'e' &&
7230 if (name[4] == 'c' &&
7239 if (name[4] == 'n' &&
7255 if (name[1] == 'r' &&
7273 if (name[3] == 'a' &&
7283 if (name[3] == 'u' &&
7297 if (name[2] == 'n' &&
7315 if (name[2] == 'a' &&
7329 if (name[3] == 'e' &&
7342 if (name[4] == 't' &&
7351 if (name[4] == 'e' &&
7373 if (name[4] == 't' &&
7382 if (name[4] == 'e' &&
7398 if (name[2] == 'c' &&
7409 if (name[2] == 'l' &&
7420 if (name[2] == 'b' &&
7431 if (name[2] == 's' &&
7454 if (name[4] == 's' &&
7463 if (name[4] == 'n' &&
7476 if (name[3] == 'a' &&
7493 if (name[1] == 'a' &&
7508 case 7: /* 28 tokens of length 7 */
7512 if (name[1] == 'E' &&
7525 if (name[1] == '_' &&
7538 if (name[1] == 'i' &&
7545 return -KEY_binmode;
7551 if (name[1] == 'o' &&
7558 return -KEY_connect;
7567 if (name[2] == 'm' &&
7573 return -KEY_dbmopen;
7579 if (name[2] == 'f' &&
7595 if (name[1] == 'o' &&
7608 if (name[1] == 'e' &&
7615 if (name[5] == 'r' &&
7618 return -KEY_getpgrp;
7624 if (name[5] == 'i' &&
7627 return -KEY_getppid;
7640 if (name[1] == 'c' &&
7647 return -KEY_lcfirst;
7653 if (name[1] == 'p' &&
7660 return -KEY_opendir;
7666 if (name[1] == 'a' &&
7684 if (name[3] == 'd' &&
7689 return -KEY_readdir;
7695 if (name[3] == 'u' &&
7706 if (name[3] == 'e' &&
7711 return -KEY_reverse;
7730 if (name[3] == 'k' &&
7735 return -KEY_seekdir;
7741 if (name[3] == 'p' &&
7746 return -KEY_setpgrp;
7756 if (name[2] == 'm' &&
7762 return -KEY_shmread;
7768 if (name[2] == 'r' &&
7774 return -KEY_sprintf;
7783 if (name[3] == 'l' &&
7788 return -KEY_symlink;
7797 if (name[4] == 'a' &&
7801 return -KEY_syscall;
7807 if (name[4] == 'p' &&
7811 return -KEY_sysopen;
7817 if (name[4] == 'e' &&
7821 return -KEY_sysread;
7827 if (name[4] == 'e' &&
7831 return -KEY_sysseek;
7849 if (name[1] == 'e' &&
7856 return -KEY_telldir;
7865 if (name[2] == 'f' &&
7871 return -KEY_ucfirst;
7877 if (name[2] == 's' &&
7883 return -KEY_unshift;
7893 if (name[1] == 'a' &&
7900 return -KEY_waitpid;
7909 case 8: /* 26 tokens of length 8 */
7913 if (name[1] == 'U' &&
7921 return KEY_AUTOLOAD;
7932 if (name[3] == 'A' &&
7938 return KEY___DATA__;
7944 if (name[3] == 'I' &&
7950 return -KEY___FILE__;
7956 if (name[3] == 'I' &&
7962 return -KEY___LINE__;
7978 if (name[2] == 'o' &&
7985 return -KEY_closedir;
7991 if (name[2] == 'n' &&
7998 return -KEY_continue;
8008 if (name[1] == 'b' &&
8016 return -KEY_dbmclose;
8022 if (name[1] == 'n' &&
8028 if (name[4] == 'r' &&
8033 return -KEY_endgrent;
8039 if (name[4] == 'w' &&
8044 return -KEY_endpwent;
8057 if (name[1] == 'o' &&
8065 return -KEY_formline;
8071 if (name[1] == 'e' &&
8082 if (name[6] == 'n' &&
8085 return -KEY_getgrent;
8091 if (name[6] == 'i' &&
8094 return -KEY_getgrgid;
8100 if (name[6] == 'a' &&
8103 return -KEY_getgrnam;
8116 if (name[4] == 'o' &&
8121 return -KEY_getlogin;
8132 if (name[6] == 'n' &&
8135 return -KEY_getpwent;
8141 if (name[6] == 'a' &&
8144 return -KEY_getpwnam;
8150 if (name[6] == 'i' &&
8153 return -KEY_getpwuid;
8173 if (name[1] == 'e' &&
8180 if (name[5] == 'i' &&
8187 return -KEY_readline;
8192 return -KEY_readlink;
8203 if (name[5] == 'i' &&
8207 return -KEY_readpipe;
8228 if (name[4] == 'r' &&
8233 return -KEY_setgrent;
8239 if (name[4] == 'w' &&
8244 return -KEY_setpwent;
8260 if (name[3] == 'w' &&
8266 return -KEY_shmwrite;
8272 if (name[3] == 't' &&
8278 return -KEY_shutdown;
8288 if (name[2] == 's' &&
8295 return -KEY_syswrite;
8305 if (name[1] == 'r' &&
8313 return -KEY_truncate;
8322 case 9: /* 8 tokens of length 9 */
8326 if (name[1] == 'n' &&
8335 return -KEY_endnetent;
8341 if (name[1] == 'e' &&
8350 return -KEY_getnetent;
8356 if (name[1] == 'o' &&
8365 return -KEY_localtime;
8371 if (name[1] == 'r' &&
8380 return KEY_prototype;
8386 if (name[1] == 'u' &&
8395 return -KEY_quotemeta;
8401 if (name[1] == 'e' &&
8410 return -KEY_rewinddir;
8416 if (name[1] == 'e' &&
8425 return -KEY_setnetent;
8431 if (name[1] == 'a' &&
8440 return -KEY_wantarray;
8449 case 10: /* 9 tokens of length 10 */
8453 if (name[1] == 'n' &&
8459 if (name[4] == 'o' &&
8466 return -KEY_endhostent;
8472 if (name[4] == 'e' &&
8479 return -KEY_endservent;
8492 if (name[1] == 'e' &&
8498 if (name[4] == 'o' &&
8505 return -KEY_gethostent;
8514 if (name[5] == 'r' &&
8520 return -KEY_getservent;
8526 if (name[5] == 'c' &&
8532 return -KEY_getsockopt;
8557 if (name[4] == 'o' &&
8564 return -KEY_sethostent;
8573 if (name[5] == 'r' &&
8579 return -KEY_setservent;
8585 if (name[5] == 'c' &&
8591 return -KEY_setsockopt;
8608 if (name[2] == 'c' &&
8617 return -KEY_socketpair;
8630 case 11: /* 8 tokens of length 11 */
8634 if (name[1] == '_' &&
8645 return -KEY___PACKAGE__;
8651 if (name[1] == 'n' &&
8662 return -KEY_endprotoent;
8668 if (name[1] == 'e' &&
8677 if (name[5] == 'e' &&
8684 return -KEY_getpeername;
8693 if (name[6] == 'o' &&
8699 return -KEY_getpriority;
8705 if (name[6] == 't' &&
8711 return -KEY_getprotoent;
8725 if (name[4] == 'o' &&
8733 return -KEY_getsockname;
8746 if (name[1] == 'e' &&
8754 if (name[6] == 'o' &&
8760 return -KEY_setpriority;
8766 if (name[6] == 't' &&
8772 return -KEY_setprotoent;
8788 case 12: /* 2 tokens of length 12 */
8789 if (name[0] == 'g' &&
8801 if (name[9] == 'd' &&
8804 { /* getnetbyaddr */
8805 return -KEY_getnetbyaddr;
8811 if (name[9] == 'a' &&
8814 { /* getnetbyname */
8815 return -KEY_getnetbyname;
8827 case 13: /* 4 tokens of length 13 */
8828 if (name[0] == 'g' &&
8835 if (name[4] == 'o' &&
8844 if (name[10] == 'd' &&
8847 { /* gethostbyaddr */
8848 return -KEY_gethostbyaddr;
8854 if (name[10] == 'a' &&
8857 { /* gethostbyname */
8858 return -KEY_gethostbyname;
8871 if (name[4] == 'e' &&
8880 if (name[10] == 'a' &&
8883 { /* getservbyname */
8884 return -KEY_getservbyname;
8890 if (name[10] == 'o' &&
8893 { /* getservbyport */
8894 return -KEY_getservbyport;
8913 case 14: /* 1 tokens of length 14 */
8914 if (name[0] == 'g' &&
8928 { /* getprotobyname */
8929 return -KEY_getprotobyname;
8934 case 16: /* 1 tokens of length 16 */
8935 if (name[0] == 'g' &&
8951 { /* getprotobynumber */
8952 return -KEY_getprotobynumber;
8966 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
8970 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8971 if (ckWARN(WARN_SYNTAX)) {
8973 for (w = s+2; *w && level; w++) {
8980 for (; *w && isSPACE(*w); w++) ;
8981 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
8982 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8983 "%s (...) interpreted as function",name);
8986 while (s < PL_bufend && isSPACE(*s))
8990 while (s < PL_bufend && isSPACE(*s))
8992 if (isIDFIRST_lazy_if(s,UTF)) {
8994 while (isALNUM_lazy_if(s,UTF))
8996 while (s < PL_bufend && isSPACE(*s))
9000 *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
9001 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
9005 Perl_croak(aTHX_ "No comma allowed after %s", what);
9010 /* Either returns sv, or mortalizes sv and returns a new SV*.
9011 Best used as sv=new_constant(..., sv, ...).
9012 If s, pv are NULL, calls subroutine with one argument,
9013 and type is used with error messages only. */
9016 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9020 HV * const table = GvHV(PL_hintgv); /* ^H */
9024 const char *why1 = "", *why2 = "", *why3 = "";
9026 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9029 why2 = strEQ(key,"charnames")
9030 ? "(possibly a missing \"use charnames ...\")"
9032 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9033 (type ? type: "undef"), why2);
9035 /* This is convoluted and evil ("goto considered harmful")
9036 * but I do not understand the intricacies of all the different
9037 * failure modes of %^H in here. The goal here is to make
9038 * the most probable error message user-friendly. --jhi */
9043 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9044 (type ? type: "undef"), why1, why2, why3);
9046 yyerror(SvPVX_const(msg));
9050 cvp = hv_fetch(table, key, strlen(key), FALSE);
9051 if (!cvp || !SvOK(*cvp)) {
9054 why3 = "} is not defined";
9057 sv_2mortal(sv); /* Parent created it permanently */
9060 pv = sv_2mortal(newSVpvn(s, len));
9062 typesv = sv_2mortal(newSVpv(type, 0));
9064 typesv = &PL_sv_undef;
9066 PUSHSTACKi(PERLSI_OVERLOAD);
9078 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9082 /* Check the eval first */
9083 if (!PL_in_eval && SvTRUE(ERRSV)) {
9084 sv_catpv(ERRSV, "Propagated");
9085 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9087 res = SvREFCNT_inc(sv);
9091 (void)SvREFCNT_inc(res);
9100 why1 = "Call to &{$^H{";
9102 why3 = "}} did not return a defined value";
9110 /* Returns a NUL terminated string, with the length of the string written to
9114 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9116 register char *d = dest;
9117 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
9120 Perl_croak(aTHX_ ident_too_long);
9121 if (isALNUM(*s)) /* UTF handled below */
9123 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9128 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9132 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9133 char *t = s + UTF8SKIP(s);
9134 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9136 if (d + (t - s) > e)
9137 Perl_croak(aTHX_ ident_too_long);
9138 Copy(s, d, t - s, char);
9151 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9155 char *bracket = Nullch;
9161 e = d + destlen - 3; /* two-character token, ending NUL */
9163 while (isDIGIT(*s)) {
9165 Perl_croak(aTHX_ ident_too_long);
9172 Perl_croak(aTHX_ ident_too_long);
9173 if (isALNUM(*s)) /* UTF handled below */
9175 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9180 else if (*s == ':' && s[1] == ':') {
9184 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9185 char *t = s + UTF8SKIP(s);
9186 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9188 if (d + (t - s) > e)
9189 Perl_croak(aTHX_ ident_too_long);
9190 Copy(s, d, t - s, char);
9201 if (PL_lex_state != LEX_NORMAL)
9202 PL_lex_state = LEX_INTERPENDMAYBE;
9205 if (*s == '$' && s[1] &&
9206 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9219 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9224 if (isSPACE(s[-1])) {
9226 const char ch = *s++;
9227 if (!SPACE_OR_TAB(ch)) {
9233 if (isIDFIRST_lazy_if(d,UTF)) {
9237 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9239 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9242 Copy(s, d, e - s, char);
9247 while ((isALNUM(*s) || *s == ':') && d < e)
9250 Perl_croak(aTHX_ ident_too_long);
9253 while (s < send && SPACE_OR_TAB(*s)) s++;
9254 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9255 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9256 const char *brack = *s == '[' ? "[...]" : "{...}";
9257 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9258 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9259 funny, dest, brack, funny, dest, brack);
9262 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9266 /* Handle extended ${^Foo} variables
9267 * 1999-02-27 mjd-perl-patch@plover.com */
9268 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9272 while (isALNUM(*s) && d < e) {
9276 Perl_croak(aTHX_ ident_too_long);
9281 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9282 PL_lex_state = LEX_INTERPEND;
9287 if (PL_lex_state == LEX_NORMAL) {
9288 if (ckWARN(WARN_AMBIGUOUS) &&
9289 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9291 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9292 "Ambiguous use of %c{%s} resolved to %c%s",
9293 funny, dest, funny, dest);
9298 s = bracket; /* let the parser handle it */
9302 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9303 PL_lex_state = LEX_INTERPEND;
9308 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9313 *pmfl |= PMf_GLOBAL;
9315 *pmfl |= PMf_CONTINUE;
9319 *pmfl |= PMf_MULTILINE;
9321 *pmfl |= PMf_SINGLELINE;
9323 *pmfl |= PMf_EXTENDED;
9327 S_scan_pat(pTHX_ char *start, I32 type)
9330 char *s = scan_str(start,FALSE,FALSE);
9333 char * const delimiter = skipspace(start);
9334 Perl_croak(aTHX_ *delimiter == '?'
9335 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9336 : "Search pattern not terminated" );
9339 pm = (PMOP*)newPMOP(type, 0);
9340 if (PL_multi_open == '?')
9341 pm->op_pmflags |= PMf_ONCE;
9343 while (*s && strchr("iomsx", *s))
9344 pmflag(&pm->op_pmflags,*s++);
9347 while (*s && strchr("iogcmsx", *s))
9348 pmflag(&pm->op_pmflags,*s++);
9350 /* issue a warning if /c is specified,but /g is not */
9351 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9352 && ckWARN(WARN_REGEXP))
9354 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
9357 pm->op_pmpermflags = pm->op_pmflags;
9359 PL_lex_op = (OP*)pm;
9360 yylval.ival = OP_MATCH;
9365 S_scan_subst(pTHX_ char *start)
9373 yylval.ival = OP_NULL;
9375 s = scan_str(start,FALSE,FALSE);
9378 Perl_croak(aTHX_ "Substitution pattern not terminated");
9380 if (s[-1] == PL_multi_open)
9383 first_start = PL_multi_start;
9384 s = scan_str(s,FALSE,FALSE);
9387 SvREFCNT_dec(PL_lex_stuff);
9388 PL_lex_stuff = Nullsv;
9390 Perl_croak(aTHX_ "Substitution replacement not terminated");
9392 PL_multi_start = first_start; /* so whole substitution is taken together */
9394 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9400 else if (strchr("iogcmsx", *s))
9401 pmflag(&pm->op_pmflags,*s++);
9406 /* /c is not meaningful with s/// */
9407 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP))
9409 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
9414 PL_sublex_info.super_bufptr = s;
9415 PL_sublex_info.super_bufend = PL_bufend;
9417 pm->op_pmflags |= PMf_EVAL;
9418 repl = newSVpvn("",0);
9420 sv_catpv(repl, es ? "eval " : "do ");
9421 sv_catpvn(repl, "{ ", 2);
9422 sv_catsv(repl, PL_lex_repl);
9423 sv_catpvn(repl, " };", 2);
9425 SvREFCNT_dec(PL_lex_repl);
9429 pm->op_pmpermflags = pm->op_pmflags;
9430 PL_lex_op = (OP*)pm;
9431 yylval.ival = OP_SUBST;
9436 S_scan_trans(pTHX_ char *start)
9445 yylval.ival = OP_NULL;
9447 s = scan_str(start,FALSE,FALSE);
9449 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9450 if (s[-1] == PL_multi_open)
9453 s = scan_str(s,FALSE,FALSE);
9456 SvREFCNT_dec(PL_lex_stuff);
9457 PL_lex_stuff = Nullsv;
9459 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9462 complement = del = squash = 0;
9466 complement = OPpTRANS_COMPLEMENT;
9469 del = OPpTRANS_DELETE;
9472 squash = OPpTRANS_SQUASH;
9481 Newx(tbl, complement&&!del?258:256, short);
9482 o = newPVOP(OP_TRANS, 0, (char*)tbl);
9483 o->op_private &= ~OPpTRANS_ALL;
9484 o->op_private |= del|squash|complement|
9485 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9486 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9489 yylval.ival = OP_TRANS;
9494 S_scan_heredoc(pTHX_ register char *s)
9497 I32 op_type = OP_SCALAR;
9501 const char newline[] = "\n";
9502 const char *found_newline;
9506 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9510 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9513 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9514 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9517 s = delimcpy(d, e, s, PL_bufend, term, &len);
9527 if (!isALNUM_lazy_if(s,UTF))
9528 deprecate_old("bare << to mean <<\"\"");
9529 for (; isALNUM_lazy_if(s,UTF); s++) {
9534 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9535 Perl_croak(aTHX_ "Delimiter for here document is too long");
9538 len = d - PL_tokenbuf;
9539 #ifndef PERL_STRICT_CR
9540 d = strchr(s, '\r');
9542 char * const olds = s;
9544 while (s < PL_bufend) {
9550 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9559 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9563 if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) {
9564 herewas = newSVpvn(s,PL_bufend-s);
9568 herewas = newSVpvn(s,found_newline-s);
9570 s += SvCUR(herewas);
9572 tmpstr = NEWSV(87,79);
9573 sv_upgrade(tmpstr, SVt_PVIV);
9576 SvIV_set(tmpstr, -1);
9578 else if (term == '`') {
9579 op_type = OP_BACKTICK;
9580 SvIV_set(tmpstr, '\\');
9584 PL_multi_start = CopLINE(PL_curcop);
9585 PL_multi_open = PL_multi_close = '<';
9586 term = *PL_tokenbuf;
9587 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9588 char *bufptr = PL_sublex_info.super_bufptr;
9589 char *bufend = PL_sublex_info.super_bufend;
9590 char * const olds = s - SvCUR(herewas);
9591 s = strchr(bufptr, '\n');
9595 while (s < bufend &&
9596 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9598 CopLINE_inc(PL_curcop);
9601 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9602 missingterm(PL_tokenbuf);
9604 sv_setpvn(herewas,bufptr,d-bufptr+1);
9605 sv_setpvn(tmpstr,d+1,s-d);
9607 sv_catpvn(herewas,s,bufend-s);
9608 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9615 while (s < PL_bufend &&
9616 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9618 CopLINE_inc(PL_curcop);
9620 if (s >= PL_bufend) {
9621 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9622 missingterm(PL_tokenbuf);
9624 sv_setpvn(tmpstr,d+1,s-d);
9626 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9628 sv_catpvn(herewas,s,PL_bufend-s);
9629 sv_setsv(PL_linestr,herewas);
9630 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9631 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9632 PL_last_lop = PL_last_uni = Nullch;
9635 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
9636 while (s >= PL_bufend) { /* multiple line string? */
9638 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9639 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9640 missingterm(PL_tokenbuf);
9642 CopLINE_inc(PL_curcop);
9643 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9644 PL_last_lop = PL_last_uni = Nullch;
9645 #ifndef PERL_STRICT_CR
9646 if (PL_bufend - PL_linestart >= 2) {
9647 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9648 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9650 PL_bufend[-2] = '\n';
9652 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9654 else if (PL_bufend[-1] == '\r')
9655 PL_bufend[-1] = '\n';
9657 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9658 PL_bufend[-1] = '\n';
9660 if (PERLDB_LINE && PL_curstash != PL_debstash) {
9661 SV *sv = NEWSV(88,0);
9663 sv_upgrade(sv, SVt_PVMG);
9664 sv_setsv(sv,PL_linestr);
9667 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9669 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9670 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9671 *(SvPVX(PL_linestr) + off ) = ' ';
9672 sv_catsv(PL_linestr,herewas);
9673 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9674 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9678 sv_catsv(tmpstr,PL_linestr);
9683 PL_multi_end = CopLINE(PL_curcop);
9684 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9685 SvPV_shrink_to_cur(tmpstr);
9687 SvREFCNT_dec(herewas);
9689 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9691 else if (PL_encoding)
9692 sv_recode_to_utf8(tmpstr, PL_encoding);
9694 PL_lex_stuff = tmpstr;
9695 yylval.ival = op_type;
9700 takes: current position in input buffer
9701 returns: new position in input buffer
9702 side-effects: yylval and lex_op are set.
9707 <FH> read from filehandle
9708 <pkg::FH> read from package qualified filehandle
9709 <pkg'FH> read from package qualified filehandle
9710 <$fh> read from filehandle in $fh
9716 S_scan_inputsymbol(pTHX_ char *start)
9718 register char *s = start; /* current position in buffer */
9724 d = PL_tokenbuf; /* start of temp holding space */
9725 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9726 end = strchr(s, '\n');
9729 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9731 /* die if we didn't have space for the contents of the <>,
9732 or if it didn't end, or if we see a newline
9735 if (len >= sizeof PL_tokenbuf)
9736 Perl_croak(aTHX_ "Excessively long <> operator");
9738 Perl_croak(aTHX_ "Unterminated <> operator");
9743 Remember, only scalar variables are interpreted as filehandles by
9744 this code. Anything more complex (e.g., <$fh{$num}>) will be
9745 treated as a glob() call.
9746 This code makes use of the fact that except for the $ at the front,
9747 a scalar variable and a filehandle look the same.
9749 if (*d == '$' && d[1]) d++;
9751 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9752 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9755 /* If we've tried to read what we allow filehandles to look like, and
9756 there's still text left, then it must be a glob() and not a getline.
9757 Use scan_str to pull out the stuff between the <> and treat it
9758 as nothing more than a string.
9761 if (d - PL_tokenbuf != len) {
9762 yylval.ival = OP_GLOB;
9764 s = scan_str(start,FALSE,FALSE);
9766 Perl_croak(aTHX_ "Glob not terminated");
9770 bool readline_overriden = FALSE;
9771 GV *gv_readline = Nullgv;
9773 /* we're in a filehandle read situation */
9776 /* turn <> into <ARGV> */
9778 Copy("ARGV",d,5,char);
9780 /* Check whether readline() is overriden */
9781 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9782 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9784 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9785 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9786 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9787 readline_overriden = TRUE;
9789 /* if <$fh>, create the ops to turn the variable into a
9795 /* try to find it in the pad for this block, otherwise find
9796 add symbol table ops
9798 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9799 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9800 HV *stash = PAD_COMPNAME_OURSTASH(tmp);
9801 HEK *stashname = HvNAME_HEK(stash);
9802 SV *sym = sv_2mortal(newSVhek(stashname));
9803 sv_catpvn(sym, "::", 2);
9809 OP *o = newOP(OP_PADSV, 0);
9811 PL_lex_op = readline_overriden
9812 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9813 append_elem(OP_LIST, o,
9814 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9815 : (OP*)newUNOP(OP_READLINE, 0, o);
9824 ? (GV_ADDMULTI | GV_ADDINEVAL)
9827 PL_lex_op = readline_overriden
9828 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9829 append_elem(OP_LIST,
9830 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9831 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9832 : (OP*)newUNOP(OP_READLINE, 0,
9833 newUNOP(OP_RV2SV, 0,
9834 newGVOP(OP_GV, 0, gv)));
9836 if (!readline_overriden)
9837 PL_lex_op->op_flags |= OPf_SPECIAL;
9838 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9839 yylval.ival = OP_NULL;
9842 /* If it's none of the above, it must be a literal filehandle
9843 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9845 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9846 PL_lex_op = readline_overriden
9847 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9848 append_elem(OP_LIST,
9849 newGVOP(OP_GV, 0, gv),
9850 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9851 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9852 yylval.ival = OP_NULL;
9861 takes: start position in buffer
9862 keep_quoted preserve \ on the embedded delimiter(s)
9863 keep_delims preserve the delimiters around the string
9864 returns: position to continue reading from buffer
9865 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9866 updates the read buffer.
9868 This subroutine pulls a string out of the input. It is called for:
9869 q single quotes q(literal text)
9870 ' single quotes 'literal text'
9871 qq double quotes qq(interpolate $here please)
9872 " double quotes "interpolate $here please"
9873 qx backticks qx(/bin/ls -l)
9874 ` backticks `/bin/ls -l`
9875 qw quote words @EXPORT_OK = qw( func() $spam )
9876 m// regexp match m/this/
9877 s/// regexp substitute s/this/that/
9878 tr/// string transliterate tr/this/that/
9879 y/// string transliterate y/this/that/
9880 ($*@) sub prototypes sub foo ($)
9881 (stuff) sub attr parameters sub foo : attr(stuff)
9882 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9884 In most of these cases (all but <>, patterns and transliterate)
9885 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9886 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9887 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9890 It skips whitespace before the string starts, and treats the first
9891 character as the delimiter. If the delimiter is one of ([{< then
9892 the corresponding "close" character )]}> is used as the closing
9893 delimiter. It allows quoting of delimiters, and if the string has
9894 balanced delimiters ([{<>}]) it allows nesting.
9896 On success, the SV with the resulting string is put into lex_stuff or,
9897 if that is already non-NULL, into lex_repl. The second case occurs only
9898 when parsing the RHS of the special constructs s/// and tr/// (y///).
9899 For convenience, the terminating delimiter character is stuffed into
9904 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9906 SV *sv; /* scalar value: string */
9907 char *tmps; /* temp string, used for delimiter matching */
9908 register char *s = start; /* current position in the buffer */
9909 register char term; /* terminating character */
9910 register char *to; /* current position in the sv's data */
9911 I32 brackets = 1; /* bracket nesting level */
9912 bool has_utf8 = FALSE; /* is there any utf8 content? */
9913 I32 termcode; /* terminating char. code */
9914 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9915 STRLEN termlen; /* length of terminating string */
9916 char *last = NULL; /* last position for nesting bracket */
9918 /* skip space before the delimiter */
9922 /* mark where we are, in case we need to report errors */
9925 /* after skipping whitespace, the next character is the terminator */
9928 termcode = termstr[0] = term;
9932 termcode = utf8_to_uvchr((U8*)s, &termlen);
9933 Copy(s, termstr, termlen, U8);
9934 if (!UTF8_IS_INVARIANT(term))
9938 /* mark where we are */
9939 PL_multi_start = CopLINE(PL_curcop);
9940 PL_multi_open = term;
9942 /* find corresponding closing delimiter */
9943 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9944 termcode = termstr[0] = term = tmps[5];
9946 PL_multi_close = term;
9948 /* create a new SV to hold the contents. 87 is leak category, I'm
9949 assuming. 79 is the SV's initial length. What a random number. */
9951 sv_upgrade(sv, SVt_PVIV);
9952 SvIV_set(sv, termcode);
9953 (void)SvPOK_only(sv); /* validate pointer */
9955 /* move past delimiter and try to read a complete string */
9957 sv_catpvn(sv, s, termlen);
9960 if (PL_encoding && !UTF) {
9964 int offset = s - SvPVX_const(PL_linestr);
9965 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9966 &offset, (char*)termstr, termlen);
9967 const char *ns = SvPVX_const(PL_linestr) + offset;
9968 char *svlast = SvEND(sv) - 1;
9970 for (; s < ns; s++) {
9971 if (*s == '\n' && !PL_rsfp)
9972 CopLINE_inc(PL_curcop);
9975 goto read_more_line;
9977 /* handle quoted delimiters */
9978 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9980 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9982 if ((svlast-1 - t) % 2) {
9986 SvCUR_set(sv, SvCUR(sv) - 1);
9991 if (PL_multi_open == PL_multi_close) {
9999 for (t = w = last; t < svlast; w++, t++) {
10000 /* At here, all closes are "was quoted" one,
10001 so we don't check PL_multi_close. */
10003 if (!keep_quoted && *(t+1) == PL_multi_open)
10008 else if (*t == PL_multi_open)
10016 SvCUR_set(sv, w - SvPVX_const(sv));
10019 if (--brackets <= 0)
10024 if (!keep_delims) {
10025 SvCUR_set(sv, SvCUR(sv) - 1);
10031 /* extend sv if need be */
10032 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10033 /* set 'to' to the next character in the sv's string */
10034 to = SvPVX(sv)+SvCUR(sv);
10036 /* if open delimiter is the close delimiter read unbridle */
10037 if (PL_multi_open == PL_multi_close) {
10038 for (; s < PL_bufend; s++,to++) {
10039 /* embedded newlines increment the current line number */
10040 if (*s == '\n' && !PL_rsfp)
10041 CopLINE_inc(PL_curcop);
10042 /* handle quoted delimiters */
10043 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10044 if (!keep_quoted && s[1] == term)
10046 /* any other quotes are simply copied straight through */
10050 /* terminate when run out of buffer (the for() condition), or
10051 have found the terminator */
10052 else if (*s == term) {
10055 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10058 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10064 /* if the terminator isn't the same as the start character (e.g.,
10065 matched brackets), we have to allow more in the quoting, and
10066 be prepared for nested brackets.
10069 /* read until we run out of string, or we find the terminator */
10070 for (; s < PL_bufend; s++,to++) {
10071 /* embedded newlines increment the line count */
10072 if (*s == '\n' && !PL_rsfp)
10073 CopLINE_inc(PL_curcop);
10074 /* backslashes can escape the open or closing characters */
10075 if (*s == '\\' && s+1 < PL_bufend) {
10076 if (!keep_quoted &&
10077 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10082 /* allow nested opens and closes */
10083 else if (*s == PL_multi_close && --brackets <= 0)
10085 else if (*s == PL_multi_open)
10087 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10092 /* terminate the copied string and update the sv's end-of-string */
10094 SvCUR_set(sv, to - SvPVX_const(sv));
10097 * this next chunk reads more into the buffer if we're not done yet
10101 break; /* handle case where we are done yet :-) */
10103 #ifndef PERL_STRICT_CR
10104 if (to - SvPVX_const(sv) >= 2) {
10105 if ((to[-2] == '\r' && to[-1] == '\n') ||
10106 (to[-2] == '\n' && to[-1] == '\r'))
10110 SvCUR_set(sv, to - SvPVX_const(sv));
10112 else if (to[-1] == '\r')
10115 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10120 /* if we're out of file, or a read fails, bail and reset the current
10121 line marker so we can report where the unterminated string began
10124 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10126 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10129 /* we read a line, so increment our line counter */
10130 CopLINE_inc(PL_curcop);
10132 /* update debugger info */
10133 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10134 SV *sv = NEWSV(88,0);
10136 sv_upgrade(sv, SVt_PVMG);
10137 sv_setsv(sv,PL_linestr);
10138 (void)SvIOK_on(sv);
10140 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10143 /* having changed the buffer, we must update PL_bufend */
10144 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10145 PL_last_lop = PL_last_uni = Nullch;
10148 /* at this point, we have successfully read the delimited string */
10150 if (!PL_encoding || UTF) {
10152 sv_catpvn(sv, s, termlen);
10155 if (has_utf8 || PL_encoding)
10158 PL_multi_end = CopLINE(PL_curcop);
10160 /* if we allocated too much space, give some back */
10161 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10162 SvLEN_set(sv, SvCUR(sv) + 1);
10163 SvPV_renew(sv, SvLEN(sv));
10166 /* decide whether this is the first or second quoted string we've read
10179 takes: pointer to position in buffer
10180 returns: pointer to new position in buffer
10181 side-effects: builds ops for the constant in yylval.op
10183 Read a number in any of the formats that Perl accepts:
10185 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10186 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10189 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10191 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10194 If it reads a number without a decimal point or an exponent, it will
10195 try converting the number to an integer and see if it can do so
10196 without loss of precision.
10200 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10202 register const char *s = start; /* current position in buffer */
10203 register char *d; /* destination in temp buffer */
10204 register char *e; /* end of temp buffer */
10205 NV nv; /* number read, as a double */
10206 SV *sv = Nullsv; /* place to put the converted number */
10207 bool floatit; /* boolean: int or float? */
10208 const char *lastub = 0; /* position of last underbar */
10209 static char const number_too_long[] = "Number too long";
10211 /* We use the first character to decide what type of number this is */
10215 Perl_croak(aTHX_ "panic: scan_num");
10217 /* if it starts with a 0, it could be an octal number, a decimal in
10218 0.13 disguise, or a hexadecimal number, or a binary number. */
10222 u holds the "number so far"
10223 shift the power of 2 of the base
10224 (hex == 4, octal == 3, binary == 1)
10225 overflowed was the number more than we can hold?
10227 Shift is used when we add a digit. It also serves as an "are
10228 we in octal/hex/binary?" indicator to disallow hex characters
10229 when in octal mode.
10234 bool overflowed = FALSE;
10235 bool just_zero = TRUE; /* just plain 0 or binary number? */
10236 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10237 static const char* const bases[5] =
10238 { "", "binary", "", "octal", "hexadecimal" };
10239 static const char* const Bases[5] =
10240 { "", "Binary", "", "Octal", "Hexadecimal" };
10241 static const char* const maxima[5] =
10243 "0b11111111111111111111111111111111",
10247 const char *base, *Base, *max;
10249 /* check for hex */
10254 } else if (s[1] == 'b') {
10259 /* check for a decimal in disguise */
10260 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10262 /* so it must be octal */
10269 if (ckWARN(WARN_SYNTAX))
10270 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10271 "Misplaced _ in number");
10275 base = bases[shift];
10276 Base = Bases[shift];
10277 max = maxima[shift];
10279 /* read the rest of the number */
10281 /* x is used in the overflow test,
10282 b is the digit we're adding on. */
10287 /* if we don't mention it, we're done */
10291 /* _ are ignored -- but warned about if consecutive */
10293 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10294 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10295 "Misplaced _ in number");
10299 /* 8 and 9 are not octal */
10300 case '8': case '9':
10302 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10306 case '2': case '3': case '4':
10307 case '5': case '6': case '7':
10309 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10312 case '0': case '1':
10313 b = *s++ & 15; /* ASCII digit -> value of digit */
10317 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10318 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10319 /* make sure they said 0x */
10322 b = (*s++ & 7) + 9;
10324 /* Prepare to put the digit we have onto the end
10325 of the number so far. We check for overflows.
10331 x = u << shift; /* make room for the digit */
10333 if ((x >> shift) != u
10334 && !(PL_hints & HINT_NEW_BINARY)) {
10337 if (ckWARN_d(WARN_OVERFLOW))
10338 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10339 "Integer overflow in %s number",
10342 u = x | b; /* add the digit to the end */
10345 n *= nvshift[shift];
10346 /* If an NV has not enough bits in its
10347 * mantissa to represent an UV this summing of
10348 * small low-order numbers is a waste of time
10349 * (because the NV cannot preserve the
10350 * low-order bits anyway): we could just
10351 * remember when did we overflow and in the
10352 * end just multiply n by the right
10360 /* if we get here, we had success: make a scalar value from
10365 /* final misplaced underbar check */
10366 if (s[-1] == '_') {
10367 if (ckWARN(WARN_SYNTAX))
10368 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10373 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10374 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10375 "%s number > %s non-portable",
10381 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10382 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10383 "%s number > %s non-portable",
10388 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10389 sv = new_constant(start, s - start, "integer",
10391 else if (PL_hints & HINT_NEW_BINARY)
10392 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10397 handle decimal numbers.
10398 we're also sent here when we read a 0 as the first digit
10400 case '1': case '2': case '3': case '4': case '5':
10401 case '6': case '7': case '8': case '9': case '.':
10404 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10407 /* read next group of digits and _ and copy into d */
10408 while (isDIGIT(*s) || *s == '_') {
10409 /* skip underscores, checking for misplaced ones
10413 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10414 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10415 "Misplaced _ in number");
10419 /* check for end of fixed-length buffer */
10421 Perl_croak(aTHX_ number_too_long);
10422 /* if we're ok, copy the character */
10427 /* final misplaced underbar check */
10428 if (lastub && s == lastub + 1) {
10429 if (ckWARN(WARN_SYNTAX))
10430 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10433 /* read a decimal portion if there is one. avoid
10434 3..5 being interpreted as the number 3. followed
10437 if (*s == '.' && s[1] != '.') {
10442 if (ckWARN(WARN_SYNTAX))
10443 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10444 "Misplaced _ in number");
10448 /* copy, ignoring underbars, until we run out of digits.
10450 for (; isDIGIT(*s) || *s == '_'; s++) {
10451 /* fixed length buffer check */
10453 Perl_croak(aTHX_ number_too_long);
10455 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10456 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10457 "Misplaced _ in number");
10463 /* fractional part ending in underbar? */
10464 if (s[-1] == '_') {
10465 if (ckWARN(WARN_SYNTAX))
10466 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10467 "Misplaced _ in number");
10469 if (*s == '.' && isDIGIT(s[1])) {
10470 /* oops, it's really a v-string, but without the "v" */
10476 /* read exponent part, if present */
10477 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10481 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10482 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10484 /* stray preinitial _ */
10486 if (ckWARN(WARN_SYNTAX))
10487 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10488 "Misplaced _ in number");
10492 /* allow positive or negative exponent */
10493 if (*s == '+' || *s == '-')
10496 /* stray initial _ */
10498 if (ckWARN(WARN_SYNTAX))
10499 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10500 "Misplaced _ in number");
10504 /* read digits of exponent */
10505 while (isDIGIT(*s) || *s == '_') {
10508 Perl_croak(aTHX_ number_too_long);
10512 if (((lastub && s == lastub + 1) ||
10513 (!isDIGIT(s[1]) && s[1] != '_'))
10514 && ckWARN(WARN_SYNTAX))
10515 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10516 "Misplaced _ in number");
10523 /* make an sv from the string */
10527 We try to do an integer conversion first if no characters
10528 indicating "float" have been found.
10533 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10535 if (flags == IS_NUMBER_IN_UV) {
10537 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10540 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10541 if (uv <= (UV) IV_MIN)
10542 sv_setiv(sv, -(IV)uv);
10549 /* terminate the string */
10551 nv = Atof(PL_tokenbuf);
10555 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10556 (PL_hints & HINT_NEW_INTEGER) )
10557 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10558 (floatit ? "float" : "integer"),
10562 /* if it starts with a v, it could be a v-string */
10565 sv = NEWSV(92,5); /* preallocate storage space */
10566 s = scan_vstring(s,sv);
10570 /* make the op for the constant and return */
10573 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10575 lvalp->opval = Nullop;
10581 S_scan_formline(pTHX_ register char *s)
10583 register char *eol;
10585 SV *stuff = newSVpvn("",0);
10586 bool needargs = FALSE;
10587 bool eofmt = FALSE;
10589 while (!needargs) {
10591 #ifdef PERL_STRICT_CR
10592 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10594 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10596 if (*t == '\n' || t == PL_bufend) {
10601 if (PL_in_eval && !PL_rsfp) {
10602 eol = (char *) memchr(s,'\n',PL_bufend-s);
10607 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10609 for (t = s; t < eol; t++) {
10610 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10612 goto enough; /* ~~ must be first line in formline */
10614 if (*t == '@' || *t == '^')
10618 sv_catpvn(stuff, s, eol-s);
10619 #ifndef PERL_STRICT_CR
10620 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10621 char *end = SvPVX(stuff) + SvCUR(stuff);
10624 SvCUR_set(stuff, SvCUR(stuff) - 1);
10633 s = filter_gets(PL_linestr, PL_rsfp, 0);
10634 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10635 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10636 PL_last_lop = PL_last_uni = Nullch;
10645 if (SvCUR(stuff)) {
10648 PL_lex_state = LEX_NORMAL;
10649 PL_nextval[PL_nexttoke].ival = 0;
10653 PL_lex_state = LEX_FORMLINE;
10655 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10657 else if (PL_encoding)
10658 sv_recode_to_utf8(stuff, PL_encoding);
10660 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10662 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10666 SvREFCNT_dec(stuff);
10668 PL_lex_formbrack = 0;
10679 PL_cshlen = strlen(PL_cshname);
10684 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10686 const I32 oldsavestack_ix = PL_savestack_ix;
10687 CV* outsidecv = PL_compcv;
10690 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10692 SAVEI32(PL_subline);
10693 save_item(PL_subname);
10694 SAVESPTR(PL_compcv);
10696 PL_compcv = (CV*)NEWSV(1104,0);
10697 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10698 CvFLAGS(PL_compcv) |= flags;
10700 PL_subline = CopLINE(PL_curcop);
10701 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10702 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10703 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10705 return oldsavestack_ix;
10709 #pragma segment Perl_yylex
10712 Perl_yywarn(pTHX_ const char *s)
10714 PL_in_eval |= EVAL_WARNONLY;
10716 PL_in_eval &= ~EVAL_WARNONLY;
10721 Perl_yyerror(pTHX_ const char *s)
10723 const char *where = NULL;
10724 const char *context = NULL;
10728 if (!yychar || (yychar == ';' && !PL_rsfp))
10730 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10731 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10732 PL_oldbufptr != PL_bufptr) {
10735 The code below is removed for NetWare because it abends/crashes on NetWare
10736 when the script has error such as not having the closing quotes like:
10737 if ($var eq "value)
10738 Checking of white spaces is anyway done in NetWare code.
10741 while (isSPACE(*PL_oldoldbufptr))
10744 context = PL_oldoldbufptr;
10745 contlen = PL_bufptr - PL_oldoldbufptr;
10747 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10748 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10751 The code below is removed for NetWare because it abends/crashes on NetWare
10752 when the script has error such as not having the closing quotes like:
10753 if ($var eq "value)
10754 Checking of white spaces is anyway done in NetWare code.
10757 while (isSPACE(*PL_oldbufptr))
10760 context = PL_oldbufptr;
10761 contlen = PL_bufptr - PL_oldbufptr;
10763 else if (yychar > 255)
10764 where = "next token ???";
10765 else if (yychar == -2) { /* YYEMPTY */
10766 if (PL_lex_state == LEX_NORMAL ||
10767 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10768 where = "at end of line";
10769 else if (PL_lex_inpat)
10770 where = "within pattern";
10772 where = "within string";
10775 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10777 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10778 else if (isPRINT_LC(yychar))
10779 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10781 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10782 where = SvPVX_const(where_sv);
10784 msg = sv_2mortal(newSVpv(s, 0));
10785 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10786 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10788 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10790 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10791 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10792 Perl_sv_catpvf(aTHX_ msg,
10793 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10794 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10797 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10798 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10801 if (PL_error_count >= 10) {
10802 if (PL_in_eval && SvCUR(ERRSV))
10803 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10804 ERRSV, OutCopFILE(PL_curcop));
10806 Perl_croak(aTHX_ "%s has too many errors.\n",
10807 OutCopFILE(PL_curcop));
10810 PL_in_my_stash = Nullhv;
10814 #pragma segment Main
10818 S_swallow_bom(pTHX_ U8 *s)
10820 const STRLEN slen = SvCUR(PL_linestr);
10823 if (s[1] == 0xFE) {
10824 /* UTF-16 little-endian? (or UTF32-LE?) */
10825 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10826 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10827 #ifndef PERL_NO_UTF16_FILTER
10828 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10831 if (PL_bufend > (char*)s) {
10835 filter_add(utf16rev_textfilter, NULL);
10836 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10837 utf16_to_utf8_reversed(s, news,
10838 PL_bufend - (char*)s - 1,
10840 sv_setpvn(PL_linestr, (const char*)news, newlen);
10842 SvUTF8_on(PL_linestr);
10843 s = (U8*)SvPVX(PL_linestr);
10844 PL_bufend = SvPVX(PL_linestr) + newlen;
10847 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10852 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10853 #ifndef PERL_NO_UTF16_FILTER
10854 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10857 if (PL_bufend > (char *)s) {
10861 filter_add(utf16_textfilter, NULL);
10862 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10863 utf16_to_utf8(s, news,
10864 PL_bufend - (char*)s,
10866 sv_setpvn(PL_linestr, (const char*)news, newlen);
10868 SvUTF8_on(PL_linestr);
10869 s = (U8*)SvPVX(PL_linestr);
10870 PL_bufend = SvPVX(PL_linestr) + newlen;
10873 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
10878 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10879 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10880 s += 3; /* UTF-8 */
10886 if (s[2] == 0xFE && s[3] == 0xFF) {
10887 /* UTF-32 big-endian */
10888 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
10891 else if (s[2] == 0 && s[3] != 0) {
10894 * are a good indicator of UTF-16BE. */
10895 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10900 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10903 * are a good indicator of UTF-16LE. */
10904 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10913 * Restore a source filter.
10917 restore_rsfp(pTHX_ void *f)
10919 PerlIO *fp = (PerlIO*)f;
10921 if (PL_rsfp == PerlIO_stdin())
10922 PerlIO_clearerr(PL_rsfp);
10923 else if (PL_rsfp && (PL_rsfp != fp))
10924 PerlIO_close(PL_rsfp);
10928 #ifndef PERL_NO_UTF16_FILTER
10930 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10932 const STRLEN old = SvCUR(sv);
10933 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10934 DEBUG_P(PerlIO_printf(Perl_debug_log,
10935 "utf16_textfilter(%p): %d %d (%d)\n",
10936 utf16_textfilter, idx, maxlen, (int) count));
10940 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10941 Copy(SvPVX_const(sv), tmps, old, char);
10942 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10943 SvCUR(sv) - old, &newlen);
10944 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10946 DEBUG_P({sv_dump(sv);});
10951 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10953 const STRLEN old = SvCUR(sv);
10954 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10955 DEBUG_P(PerlIO_printf(Perl_debug_log,
10956 "utf16rev_textfilter(%p): %d %d (%d)\n",
10957 utf16rev_textfilter, idx, maxlen, (int) count));
10961 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10962 Copy(SvPVX_const(sv), tmps, old, char);
10963 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10964 SvCUR(sv) - old, &newlen);
10965 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10967 DEBUG_P({ sv_dump(sv); });
10973 Returns a pointer to the next character after the parsed
10974 vstring, as well as updating the passed in sv.
10976 Function must be called like
10979 s = scan_vstring(s,sv);
10981 The sv should already be large enough to store the vstring
10982 passed in, for performance reasons.
10987 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
10989 const char *pos = s;
10990 const char *start = s;
10991 if (*pos == 'v') pos++; /* get past 'v' */
10992 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
10994 if ( *pos != '.') {
10995 /* this may not be a v-string if followed by => */
10996 const char *next = pos;
10997 while (next < PL_bufend && isSPACE(*next))
10999 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
11000 /* return string not v-string */
11001 sv_setpvn(sv,(char *)s,pos-s);
11002 return (char *)pos;
11006 if (!isALPHA(*pos)) {
11008 U8 tmpbuf[UTF8_MAXBYTES+1];
11011 if (*s == 'v') s++; /* get past 'v' */
11013 sv_setpvn(sv, "", 0);
11018 /* this is atoi() that tolerates underscores */
11019 const char *end = pos;
11021 while (--end >= s) {
11026 rev += (*end - '0') * mult;
11028 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11029 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11030 "Integer overflow in decimal number");
11034 if (rev > 0x7FFFFFFF)
11035 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11037 /* Append native character for the rev point */
11038 tmpend = uvchr_to_utf8(tmpbuf, rev);
11039 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11040 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11042 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11048 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11052 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11060 * c-indentation-style: bsd
11061 * c-basic-offset: 4
11062 * indent-tabs-mode: t
11065 * ex: set ts=8 sts=4 sw=4 noet: