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);
4534 LOP(OP_ACCEPT,XTERM);
4540 LOP(OP_ATAN2,XTERM);
4546 LOP(OP_BINMODE,XTERM);
4549 LOP(OP_BLESS,XTERM);
4558 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4575 if (!PL_cryptseen) {
4576 PL_cryptseen = TRUE;
4580 LOP(OP_CRYPT,XTERM);
4583 LOP(OP_CHMOD,XTERM);
4586 LOP(OP_CHOWN,XTERM);
4589 LOP(OP_CONNECT,XTERM);
4605 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4609 PL_hints |= HINT_BLOCK_SCOPE;
4619 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4620 LOP(OP_DBMOPEN,XTERM);
4626 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4633 yylval.ival = CopLINE(PL_curcop);
4647 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4648 UNIBRACK(OP_ENTEREVAL);
4666 case KEY_endhostent:
4672 case KEY_endservent:
4675 case KEY_endprotoent:
4686 yylval.ival = CopLINE(PL_curcop);
4688 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4690 if ((PL_bufend - p) >= 3 &&
4691 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4693 else if ((PL_bufend - p) >= 4 &&
4694 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4697 if (isIDFIRST_lazy_if(p,UTF)) {
4698 p = scan_ident(p, PL_bufend,
4699 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4703 Perl_croak(aTHX_ "Missing $ on loop variable");
4708 LOP(OP_FORMLINE,XTERM);
4714 LOP(OP_FCNTL,XTERM);
4720 LOP(OP_FLOCK,XTERM);
4729 LOP(OP_GREPSTART, XREF);
4732 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4747 case KEY_getpriority:
4748 LOP(OP_GETPRIORITY,XTERM);
4750 case KEY_getprotobyname:
4753 case KEY_getprotobynumber:
4754 LOP(OP_GPBYNUMBER,XTERM);
4756 case KEY_getprotoent:
4768 case KEY_getpeername:
4769 UNI(OP_GETPEERNAME);
4771 case KEY_gethostbyname:
4774 case KEY_gethostbyaddr:
4775 LOP(OP_GHBYADDR,XTERM);
4777 case KEY_gethostent:
4780 case KEY_getnetbyname:
4783 case KEY_getnetbyaddr:
4784 LOP(OP_GNBYADDR,XTERM);
4789 case KEY_getservbyname:
4790 LOP(OP_GSBYNAME,XTERM);
4792 case KEY_getservbyport:
4793 LOP(OP_GSBYPORT,XTERM);
4795 case KEY_getservent:
4798 case KEY_getsockname:
4799 UNI(OP_GETSOCKNAME);
4801 case KEY_getsockopt:
4802 LOP(OP_GSOCKOPT,XTERM);
4824 yylval.ival = CopLINE(PL_curcop);
4828 LOP(OP_INDEX,XTERM);
4834 LOP(OP_IOCTL,XTERM);
4846 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4878 LOP(OP_LISTEN,XTERM);
4887 s = scan_pat(s,OP_MATCH);
4888 TERM(sublex_start());
4891 LOP(OP_MAPSTART, XREF);
4894 LOP(OP_MKDIR,XTERM);
4897 LOP(OP_MSGCTL,XTERM);
4900 LOP(OP_MSGGET,XTERM);
4903 LOP(OP_MSGRCV,XTERM);
4906 LOP(OP_MSGSND,XTERM);
4912 if (isIDFIRST_lazy_if(s,UTF)) {
4913 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4914 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4916 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4917 if (!PL_in_my_stash) {
4920 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4928 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4935 s = tokenize_use(0, s);
4939 if (*s == '(' || (s = skipspace(s), *s == '('))
4946 if (isIDFIRST_lazy_if(s,UTF)) {
4948 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4949 for (t=d; *t && isSPACE(*t); t++) ;
4950 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4952 && !(t[0] == '=' && t[1] == '>')
4954 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4955 "Precedence problem: open %.*s should be open(%.*s)",
4956 d - s, s, d - s, s);
4962 yylval.ival = OP_OR;
4972 LOP(OP_OPEN_DIR,XTERM);
4975 checkcomma(s,PL_tokenbuf,"filehandle");
4979 checkcomma(s,PL_tokenbuf,"filehandle");
4998 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5002 LOP(OP_PIPE_OP,XTERM);
5005 s = scan_str(s,FALSE,FALSE);
5007 missingterm((char*)0);
5008 yylval.ival = OP_CONST;
5009 TERM(sublex_start());
5015 s = scan_str(s,FALSE,FALSE);
5017 missingterm((char*)0);
5018 PL_expect = XOPERATOR;
5020 if (SvCUR(PL_lex_stuff)) {
5023 d = SvPV_force(PL_lex_stuff, len);
5026 for (; isSPACE(*d) && len; --len, ++d) ;
5029 if (!warned && ckWARN(WARN_QW)) {
5030 for (; !isSPACE(*d) && len; --len, ++d) {
5032 Perl_warner(aTHX_ packWARN(WARN_QW),
5033 "Possible attempt to separate words with commas");
5036 else if (*d == '#') {
5037 Perl_warner(aTHX_ packWARN(WARN_QW),
5038 "Possible attempt to put comments in qw() list");
5044 for (; !isSPACE(*d) && len; --len, ++d) ;
5046 sv = newSVpvn(b, d-b);
5047 if (DO_UTF8(PL_lex_stuff))
5049 words = append_elem(OP_LIST, words,
5050 newSVOP(OP_CONST, 0, tokeq(sv)));
5054 PL_nextval[PL_nexttoke].opval = words;
5059 SvREFCNT_dec(PL_lex_stuff);
5060 PL_lex_stuff = Nullsv;
5066 s = scan_str(s,FALSE,FALSE);
5068 missingterm((char*)0);
5069 yylval.ival = OP_STRINGIFY;
5070 if (SvIVX(PL_lex_stuff) == '\'')
5071 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
5072 TERM(sublex_start());
5075 s = scan_pat(s,OP_QR);
5076 TERM(sublex_start());
5079 s = scan_str(s,FALSE,FALSE);
5081 missingterm((char*)0);
5082 yylval.ival = OP_BACKTICK;
5084 TERM(sublex_start());
5092 s = force_version(s, FALSE);
5094 else if (*s != 'v' || !isDIGIT(s[1])
5095 || (s = force_version(s, TRUE), *s == 'v'))
5097 *PL_tokenbuf = '\0';
5098 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5099 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5100 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5102 yyerror("<> should be quotes");
5110 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5114 LOP(OP_RENAME,XTERM);
5123 LOP(OP_RINDEX,XTERM);
5133 UNIDOR(OP_READLINE);
5146 LOP(OP_REVERSE,XTERM);
5149 UNIDOR(OP_READLINK);
5157 TERM(sublex_start());
5159 TOKEN(1); /* force error */
5168 LOP(OP_SELECT,XTERM);
5174 LOP(OP_SEMCTL,XTERM);
5177 LOP(OP_SEMGET,XTERM);
5180 LOP(OP_SEMOP,XTERM);
5186 LOP(OP_SETPGRP,XTERM);
5188 case KEY_setpriority:
5189 LOP(OP_SETPRIORITY,XTERM);
5191 case KEY_sethostent:
5197 case KEY_setservent:
5200 case KEY_setprotoent:
5210 LOP(OP_SEEKDIR,XTERM);
5212 case KEY_setsockopt:
5213 LOP(OP_SSOCKOPT,XTERM);
5219 LOP(OP_SHMCTL,XTERM);
5222 LOP(OP_SHMGET,XTERM);
5225 LOP(OP_SHMREAD,XTERM);
5228 LOP(OP_SHMWRITE,XTERM);
5231 LOP(OP_SHUTDOWN,XTERM);
5240 LOP(OP_SOCKET,XTERM);
5242 case KEY_socketpair:
5243 LOP(OP_SOCKPAIR,XTERM);
5246 checkcomma(s,PL_tokenbuf,"subroutine name");
5248 if (*s == ';' || *s == ')') /* probably a close */
5249 Perl_croak(aTHX_ "sort is now a reserved word");
5251 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5255 LOP(OP_SPLIT,XTERM);
5258 LOP(OP_SPRINTF,XTERM);
5261 LOP(OP_SPLICE,XTERM);
5276 LOP(OP_SUBSTR,XTERM);
5282 char tmpbuf[sizeof PL_tokenbuf];
5283 SSize_t tboffset = 0;
5284 expectation attrful;
5285 bool have_name, have_proto, bad_proto;
5286 const int key = tmp;
5290 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5291 (*s == ':' && s[1] == ':'))
5294 attrful = XATTRBLOCK;
5295 /* remember buffer pos'n for later force_word */
5296 tboffset = s - PL_oldbufptr;
5297 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5298 if (strchr(tmpbuf, ':'))
5299 sv_setpv(PL_subname, tmpbuf);
5301 sv_setsv(PL_subname,PL_curstname);
5302 sv_catpvn(PL_subname,"::",2);
5303 sv_catpvn(PL_subname,tmpbuf,len);
5310 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5311 PL_expect = XTERMBLOCK;
5312 attrful = XATTRTERM;
5313 sv_setpvn(PL_subname,"?",1);
5317 if (key == KEY_format) {
5319 PL_lex_formbrack = PL_lex_brackets + 1;
5321 (void) force_word(PL_oldbufptr + tboffset, WORD,
5326 /* Look for a prototype */
5330 s = scan_str(s,FALSE,FALSE);
5332 Perl_croak(aTHX_ "Prototype not terminated");
5333 /* strip spaces and check for bad characters */
5334 d = SvPVX(PL_lex_stuff);
5337 for (p = d; *p; ++p) {
5340 if (!strchr("$@%*;[]&\\", *p))
5345 if (bad_proto && ckWARN(WARN_SYNTAX))
5346 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5347 "Illegal character in prototype for %"SVf" : %s",
5349 SvCUR_set(PL_lex_stuff, tmp);
5357 if (*s == ':' && s[1] != ':')
5358 PL_expect = attrful;
5359 else if (*s != '{' && key == KEY_sub) {
5361 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5363 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5367 PL_nextval[PL_nexttoke].opval =
5368 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5369 PL_lex_stuff = Nullsv;
5373 sv_setpv(PL_subname,
5374 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5377 (void) force_word(PL_oldbufptr + tboffset, WORD,
5386 LOP(OP_SYSTEM,XREF);
5389 LOP(OP_SYMLINK,XTERM);
5392 LOP(OP_SYSCALL,XTERM);
5395 LOP(OP_SYSOPEN,XTERM);
5398 LOP(OP_SYSSEEK,XTERM);
5401 LOP(OP_SYSREAD,XTERM);
5404 LOP(OP_SYSWRITE,XTERM);
5408 TERM(sublex_start());
5429 LOP(OP_TRUNCATE,XTERM);
5441 yylval.ival = CopLINE(PL_curcop);
5445 yylval.ival = CopLINE(PL_curcop);
5449 LOP(OP_UNLINK,XTERM);
5455 LOP(OP_UNPACK,XTERM);
5458 LOP(OP_UTIME,XTERM);
5464 LOP(OP_UNSHIFT,XTERM);
5467 s = tokenize_use(1, s);
5477 yylval.ival = CopLINE(PL_curcop);
5481 PL_hints |= HINT_BLOCK_SCOPE;
5488 LOP(OP_WAITPID,XTERM);
5497 ctl_l[0] = toCTRL('L');
5499 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5502 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5507 if (PL_expect == XOPERATOR)
5513 yylval.ival = OP_XOR;
5518 TERM(sublex_start());
5523 #pragma segment Main
5527 S_pending_ident(pTHX)
5530 register I32 tmp = 0;
5531 /* pit holds the identifier we read and pending_ident is reset */
5532 char pit = PL_pending_ident;
5533 PL_pending_ident = 0;
5535 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5536 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5538 /* if we're in a my(), we can't allow dynamics here.
5539 $foo'bar has already been turned into $foo::bar, so
5540 just check for colons.
5542 if it's a legal name, the OP is a PADANY.
5545 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5546 if (strchr(PL_tokenbuf,':'))
5547 yyerror(Perl_form(aTHX_ "No package name allowed for "
5548 "variable %s in \"our\"",
5550 tmp = allocmy(PL_tokenbuf);
5553 if (strchr(PL_tokenbuf,':'))
5554 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5556 yylval.opval = newOP(OP_PADANY, 0);
5557 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5563 build the ops for accesses to a my() variable.
5565 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5566 then used in a comparison. This catches most, but not
5567 all cases. For instance, it catches
5568 sort { my($a); $a <=> $b }
5570 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5571 (although why you'd do that is anyone's guess).
5574 if (!strchr(PL_tokenbuf,':')) {
5576 tmp = pad_findmy(PL_tokenbuf);
5577 if (tmp != NOT_IN_PAD) {
5578 /* might be an "our" variable" */
5579 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5580 /* build ops for a bareword */
5581 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
5582 HEK * const stashname = HvNAME_HEK(stash);
5583 SV * const sym = newSVhek(stashname);
5584 sv_catpvn(sym, "::", 2);
5585 sv_catpv(sym, PL_tokenbuf+1);
5586 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5587 yylval.opval->op_private = OPpCONST_ENTERED;
5590 ? (GV_ADDMULTI | GV_ADDINEVAL)
5593 ((PL_tokenbuf[0] == '$') ? SVt_PV
5594 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5599 /* if it's a sort block and they're naming $a or $b */
5600 if (PL_last_lop_op == OP_SORT &&
5601 PL_tokenbuf[0] == '$' &&
5602 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5605 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5606 d < PL_bufend && *d != '\n';
5609 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5610 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5616 yylval.opval = newOP(OP_PADANY, 0);
5617 yylval.opval->op_targ = tmp;
5623 Whine if they've said @foo in a doublequoted string,
5624 and @foo isn't a variable we can find in the symbol
5627 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5628 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5629 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5630 && ckWARN(WARN_AMBIGUOUS))
5632 /* Downgraded from fatal to warning 20000522 mjd */
5633 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5634 "Possible unintended interpolation of %s in string",
5639 /* build ops for a bareword */
5640 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5641 yylval.opval->op_private = OPpCONST_ENTERED;
5642 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5643 ((PL_tokenbuf[0] == '$') ? SVt_PV
5644 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5650 * The following code was generated by perl_keyword.pl.
5654 Perl_keyword (pTHX_ const char *name, I32 len)
5658 case 1: /* 5 tokens of length 1 */
5690 case 2: /* 18 tokens of length 2 */
5836 case 3: /* 28 tokens of length 3 */
5840 if (name[1] == 'N' &&
5903 if (name[1] == 'i' &&
5943 if (name[1] == 'o' &&
5952 if (name[1] == 'e' &&
5961 if (name[1] == 'n' &&
5970 if (name[1] == 'o' &&
5979 if (name[1] == 'a' &&
5988 if (name[1] == 'o' &&
6050 if (name[1] == 'e' &&
6082 if (name[1] == 'i' &&
6091 if (name[1] == 's' &&
6100 if (name[1] == 'e' &&
6109 if (name[1] == 'o' &&
6121 case 4: /* 40 tokens of length 4 */
6125 if (name[1] == 'O' &&
6135 if (name[1] == 'N' &&
6145 if (name[1] == 'i' &&
6155 if (name[1] == 'h' &&
6165 if (name[1] == 'u' &&
6178 if (name[2] == 'c' &&
6187 if (name[2] == 's' &&
6196 if (name[2] == 'a' &&
6232 if (name[1] == 'o' &&
6245 if (name[2] == 't' &&
6254 if (name[2] == 'o' &&
6263 if (name[2] == 't' &&
6272 if (name[2] == 'e' &&
6285 if (name[1] == 'o' &&
6298 if (name[2] == 'y' &&
6307 if (name[2] == 'l' &&
6323 if (name[2] == 's' &&
6332 if (name[2] == 'n' &&
6341 if (name[2] == 'c' &&
6354 if (name[1] == 'e' &&
6364 if (name[1] == 'p' &&
6377 if (name[2] == 'c' &&
6386 if (name[2] == 'p' &&
6395 if (name[2] == 's' &&
6411 if (name[2] == 'n' &&
6481 if (name[2] == 'r' &&
6490 if (name[2] == 'r' &&
6499 if (name[2] == 'a' &&
6515 if (name[2] == 'l' &&
6582 case 5: /* 36 tokens of length 5 */
6586 if (name[1] == 'E' &&
6597 if (name[1] == 'H' &&
6611 if (name[2] == 'a' &&
6621 if (name[2] == 'a' &&
6635 if (name[1] == 'l' &&
6652 if (name[3] == 'i' &&
6661 if (name[3] == 'o' &&
6697 if (name[2] == 'o' &&
6707 if (name[2] == 'y' &&
6721 if (name[1] == 'l' &&
6735 if (name[2] == 'n' &&
6745 if (name[2] == 'o' &&
6762 if (name[2] == 'd' &&
6772 if (name[2] == 'c' &&
6789 if (name[2] == 'c' &&
6799 if (name[2] == 't' &&
6813 if (name[1] == 'k' &&
6824 if (name[1] == 'r' &&
6838 if (name[2] == 's' &&
6848 if (name[2] == 'd' &&
6865 if (name[2] == 'm' &&
6875 if (name[2] == 'i' &&
6885 if (name[2] == 'e' &&
6895 if (name[2] == 'l' &&
6905 if (name[2] == 'a' &&
6915 if (name[2] == 'u' &&
6929 if (name[1] == 'i' &&
6943 if (name[2] == 'a' &&
6956 if (name[3] == 'e' &&
6991 if (name[2] == 'i' &&
7008 if (name[2] == 'i' &&
7018 if (name[2] == 'i' &&
7035 case 6: /* 33 tokens of length 6 */
7039 if (name[1] == 'c' &&
7054 if (name[2] == 'l' &&
7065 if (name[2] == 'r' &&
7080 if (name[1] == 'e' &&
7095 if (name[2] == 's' &&
7100 if(ckWARN_d(WARN_SYNTAX))
7101 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7107 if (name[2] == 'i' &&
7125 if (name[2] == 'l' &&
7136 if (name[2] == 'r' &&
7151 if (name[1] == 'm' &&
7166 if (name[2] == 'n' &&
7177 if (name[2] == 's' &&
7192 if (name[1] == 's' &&
7198 if (name[4] == 't' &&
7207 if (name[4] == 'e' &&
7216 if (name[4] == 'c' &&
7225 if (name[4] == 'n' &&
7241 if (name[1] == 'r' &&
7259 if (name[3] == 'a' &&
7269 if (name[3] == 'u' &&
7283 if (name[2] == 'n' &&
7301 if (name[2] == 'a' &&
7315 if (name[3] == 'e' &&
7328 if (name[4] == 't' &&
7337 if (name[4] == 'e' &&
7359 if (name[4] == 't' &&
7368 if (name[4] == 'e' &&
7384 if (name[2] == 'c' &&
7395 if (name[2] == 'l' &&
7406 if (name[2] == 'b' &&
7417 if (name[2] == 's' &&
7440 if (name[4] == 's' &&
7449 if (name[4] == 'n' &&
7462 if (name[3] == 'a' &&
7479 if (name[1] == 'a' &&
7494 case 7: /* 28 tokens of length 7 */
7498 if (name[1] == 'E' &&
7511 if (name[1] == '_' &&
7524 if (name[1] == 'i' &&
7531 return -KEY_binmode;
7537 if (name[1] == 'o' &&
7544 return -KEY_connect;
7553 if (name[2] == 'm' &&
7559 return -KEY_dbmopen;
7565 if (name[2] == 'f' &&
7581 if (name[1] == 'o' &&
7594 if (name[1] == 'e' &&
7601 if (name[5] == 'r' &&
7604 return -KEY_getpgrp;
7610 if (name[5] == 'i' &&
7613 return -KEY_getppid;
7626 if (name[1] == 'c' &&
7633 return -KEY_lcfirst;
7639 if (name[1] == 'p' &&
7646 return -KEY_opendir;
7652 if (name[1] == 'a' &&
7670 if (name[3] == 'd' &&
7675 return -KEY_readdir;
7681 if (name[3] == 'u' &&
7692 if (name[3] == 'e' &&
7697 return -KEY_reverse;
7716 if (name[3] == 'k' &&
7721 return -KEY_seekdir;
7727 if (name[3] == 'p' &&
7732 return -KEY_setpgrp;
7742 if (name[2] == 'm' &&
7748 return -KEY_shmread;
7754 if (name[2] == 'r' &&
7760 return -KEY_sprintf;
7769 if (name[3] == 'l' &&
7774 return -KEY_symlink;
7783 if (name[4] == 'a' &&
7787 return -KEY_syscall;
7793 if (name[4] == 'p' &&
7797 return -KEY_sysopen;
7803 if (name[4] == 'e' &&
7807 return -KEY_sysread;
7813 if (name[4] == 'e' &&
7817 return -KEY_sysseek;
7835 if (name[1] == 'e' &&
7842 return -KEY_telldir;
7851 if (name[2] == 'f' &&
7857 return -KEY_ucfirst;
7863 if (name[2] == 's' &&
7869 return -KEY_unshift;
7879 if (name[1] == 'a' &&
7886 return -KEY_waitpid;
7895 case 8: /* 26 tokens of length 8 */
7899 if (name[1] == 'U' &&
7907 return KEY_AUTOLOAD;
7918 if (name[3] == 'A' &&
7924 return KEY___DATA__;
7930 if (name[3] == 'I' &&
7936 return -KEY___FILE__;
7942 if (name[3] == 'I' &&
7948 return -KEY___LINE__;
7964 if (name[2] == 'o' &&
7971 return -KEY_closedir;
7977 if (name[2] == 'n' &&
7984 return -KEY_continue;
7994 if (name[1] == 'b' &&
8002 return -KEY_dbmclose;
8008 if (name[1] == 'n' &&
8014 if (name[4] == 'r' &&
8019 return -KEY_endgrent;
8025 if (name[4] == 'w' &&
8030 return -KEY_endpwent;
8043 if (name[1] == 'o' &&
8051 return -KEY_formline;
8057 if (name[1] == 'e' &&
8068 if (name[6] == 'n' &&
8071 return -KEY_getgrent;
8077 if (name[6] == 'i' &&
8080 return -KEY_getgrgid;
8086 if (name[6] == 'a' &&
8089 return -KEY_getgrnam;
8102 if (name[4] == 'o' &&
8107 return -KEY_getlogin;
8118 if (name[6] == 'n' &&
8121 return -KEY_getpwent;
8127 if (name[6] == 'a' &&
8130 return -KEY_getpwnam;
8136 if (name[6] == 'i' &&
8139 return -KEY_getpwuid;
8159 if (name[1] == 'e' &&
8166 if (name[5] == 'i' &&
8173 return -KEY_readline;
8178 return -KEY_readlink;
8189 if (name[5] == 'i' &&
8193 return -KEY_readpipe;
8214 if (name[4] == 'r' &&
8219 return -KEY_setgrent;
8225 if (name[4] == 'w' &&
8230 return -KEY_setpwent;
8246 if (name[3] == 'w' &&
8252 return -KEY_shmwrite;
8258 if (name[3] == 't' &&
8264 return -KEY_shutdown;
8274 if (name[2] == 's' &&
8281 return -KEY_syswrite;
8291 if (name[1] == 'r' &&
8299 return -KEY_truncate;
8308 case 9: /* 8 tokens of length 9 */
8312 if (name[1] == 'n' &&
8321 return -KEY_endnetent;
8327 if (name[1] == 'e' &&
8336 return -KEY_getnetent;
8342 if (name[1] == 'o' &&
8351 return -KEY_localtime;
8357 if (name[1] == 'r' &&
8366 return KEY_prototype;
8372 if (name[1] == 'u' &&
8381 return -KEY_quotemeta;
8387 if (name[1] == 'e' &&
8396 return -KEY_rewinddir;
8402 if (name[1] == 'e' &&
8411 return -KEY_setnetent;
8417 if (name[1] == 'a' &&
8426 return -KEY_wantarray;
8435 case 10: /* 9 tokens of length 10 */
8439 if (name[1] == 'n' &&
8445 if (name[4] == 'o' &&
8452 return -KEY_endhostent;
8458 if (name[4] == 'e' &&
8465 return -KEY_endservent;
8478 if (name[1] == 'e' &&
8484 if (name[4] == 'o' &&
8491 return -KEY_gethostent;
8500 if (name[5] == 'r' &&
8506 return -KEY_getservent;
8512 if (name[5] == 'c' &&
8518 return -KEY_getsockopt;
8543 if (name[4] == 'o' &&
8550 return -KEY_sethostent;
8559 if (name[5] == 'r' &&
8565 return -KEY_setservent;
8571 if (name[5] == 'c' &&
8577 return -KEY_setsockopt;
8594 if (name[2] == 'c' &&
8603 return -KEY_socketpair;
8616 case 11: /* 8 tokens of length 11 */
8620 if (name[1] == '_' &&
8631 return -KEY___PACKAGE__;
8637 if (name[1] == 'n' &&
8648 return -KEY_endprotoent;
8654 if (name[1] == 'e' &&
8663 if (name[5] == 'e' &&
8670 return -KEY_getpeername;
8679 if (name[6] == 'o' &&
8685 return -KEY_getpriority;
8691 if (name[6] == 't' &&
8697 return -KEY_getprotoent;
8711 if (name[4] == 'o' &&
8719 return -KEY_getsockname;
8732 if (name[1] == 'e' &&
8740 if (name[6] == 'o' &&
8746 return -KEY_setpriority;
8752 if (name[6] == 't' &&
8758 return -KEY_setprotoent;
8774 case 12: /* 2 tokens of length 12 */
8775 if (name[0] == 'g' &&
8787 if (name[9] == 'd' &&
8790 { /* getnetbyaddr */
8791 return -KEY_getnetbyaddr;
8797 if (name[9] == 'a' &&
8800 { /* getnetbyname */
8801 return -KEY_getnetbyname;
8813 case 13: /* 4 tokens of length 13 */
8814 if (name[0] == 'g' &&
8821 if (name[4] == 'o' &&
8830 if (name[10] == 'd' &&
8833 { /* gethostbyaddr */
8834 return -KEY_gethostbyaddr;
8840 if (name[10] == 'a' &&
8843 { /* gethostbyname */
8844 return -KEY_gethostbyname;
8857 if (name[4] == 'e' &&
8866 if (name[10] == 'a' &&
8869 { /* getservbyname */
8870 return -KEY_getservbyname;
8876 if (name[10] == 'o' &&
8879 { /* getservbyport */
8880 return -KEY_getservbyport;
8899 case 14: /* 1 tokens of length 14 */
8900 if (name[0] == 'g' &&
8914 { /* getprotobyname */
8915 return -KEY_getprotobyname;
8920 case 16: /* 1 tokens of length 16 */
8921 if (name[0] == 'g' &&
8937 { /* getprotobynumber */
8938 return -KEY_getprotobynumber;
8952 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
8956 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8957 if (ckWARN(WARN_SYNTAX)) {
8959 for (w = s+2; *w && level; w++) {
8966 for (; *w && isSPACE(*w); w++) ;
8967 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
8968 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8969 "%s (...) interpreted as function",name);
8972 while (s < PL_bufend && isSPACE(*s))
8976 while (s < PL_bufend && isSPACE(*s))
8978 if (isIDFIRST_lazy_if(s,UTF)) {
8980 while (isALNUM_lazy_if(s,UTF))
8982 while (s < PL_bufend && isSPACE(*s))
8986 *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
8987 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
8991 Perl_croak(aTHX_ "No comma allowed after %s", what);
8996 /* Either returns sv, or mortalizes sv and returns a new SV*.
8997 Best used as sv=new_constant(..., sv, ...).
8998 If s, pv are NULL, calls subroutine with one argument,
8999 and type is used with error messages only. */
9002 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9006 HV * const table = GvHV(PL_hintgv); /* ^H */
9010 const char *why1 = "", *why2 = "", *why3 = "";
9012 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9015 why2 = strEQ(key,"charnames")
9016 ? "(possibly a missing \"use charnames ...\")"
9018 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9019 (type ? type: "undef"), why2);
9021 /* This is convoluted and evil ("goto considered harmful")
9022 * but I do not understand the intricacies of all the different
9023 * failure modes of %^H in here. The goal here is to make
9024 * the most probable error message user-friendly. --jhi */
9029 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9030 (type ? type: "undef"), why1, why2, why3);
9032 yyerror(SvPVX_const(msg));
9036 cvp = hv_fetch(table, key, strlen(key), FALSE);
9037 if (!cvp || !SvOK(*cvp)) {
9040 why3 = "} is not defined";
9043 sv_2mortal(sv); /* Parent created it permanently */
9046 pv = sv_2mortal(newSVpvn(s, len));
9048 typesv = sv_2mortal(newSVpv(type, 0));
9050 typesv = &PL_sv_undef;
9052 PUSHSTACKi(PERLSI_OVERLOAD);
9064 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9068 /* Check the eval first */
9069 if (!PL_in_eval && SvTRUE(ERRSV)) {
9070 sv_catpv(ERRSV, "Propagated");
9071 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9073 res = SvREFCNT_inc(sv);
9077 (void)SvREFCNT_inc(res);
9086 why1 = "Call to &{$^H{";
9088 why3 = "}} did not return a defined value";
9096 /* Returns a NUL terminated string, with the length of the string written to
9100 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9102 register char *d = dest;
9103 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
9106 Perl_croak(aTHX_ ident_too_long);
9107 if (isALNUM(*s)) /* UTF handled below */
9109 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9114 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9118 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9119 char *t = s + UTF8SKIP(s);
9120 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9122 if (d + (t - s) > e)
9123 Perl_croak(aTHX_ ident_too_long);
9124 Copy(s, d, t - s, char);
9137 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9141 char *bracket = Nullch;
9147 e = d + destlen - 3; /* two-character token, ending NUL */
9149 while (isDIGIT(*s)) {
9151 Perl_croak(aTHX_ ident_too_long);
9158 Perl_croak(aTHX_ ident_too_long);
9159 if (isALNUM(*s)) /* UTF handled below */
9161 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9166 else if (*s == ':' && s[1] == ':') {
9170 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9171 char *t = s + UTF8SKIP(s);
9172 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9174 if (d + (t - s) > e)
9175 Perl_croak(aTHX_ ident_too_long);
9176 Copy(s, d, t - s, char);
9187 if (PL_lex_state != LEX_NORMAL)
9188 PL_lex_state = LEX_INTERPENDMAYBE;
9191 if (*s == '$' && s[1] &&
9192 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9205 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9210 if (isSPACE(s[-1])) {
9212 const char ch = *s++;
9213 if (!SPACE_OR_TAB(ch)) {
9219 if (isIDFIRST_lazy_if(d,UTF)) {
9223 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9225 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9228 Copy(s, d, e - s, char);
9233 while ((isALNUM(*s) || *s == ':') && d < e)
9236 Perl_croak(aTHX_ ident_too_long);
9239 while (s < send && SPACE_OR_TAB(*s)) s++;
9240 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9241 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9242 const char *brack = *s == '[' ? "[...]" : "{...}";
9243 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9244 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9245 funny, dest, brack, funny, dest, brack);
9248 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9252 /* Handle extended ${^Foo} variables
9253 * 1999-02-27 mjd-perl-patch@plover.com */
9254 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9258 while (isALNUM(*s) && d < e) {
9262 Perl_croak(aTHX_ ident_too_long);
9267 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9268 PL_lex_state = LEX_INTERPEND;
9273 if (PL_lex_state == LEX_NORMAL) {
9274 if (ckWARN(WARN_AMBIGUOUS) &&
9275 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9277 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9278 "Ambiguous use of %c{%s} resolved to %c%s",
9279 funny, dest, funny, dest);
9284 s = bracket; /* let the parser handle it */
9288 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9289 PL_lex_state = LEX_INTERPEND;
9294 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9299 *pmfl |= PMf_GLOBAL;
9301 *pmfl |= PMf_CONTINUE;
9305 *pmfl |= PMf_MULTILINE;
9307 *pmfl |= PMf_SINGLELINE;
9309 *pmfl |= PMf_EXTENDED;
9313 S_scan_pat(pTHX_ char *start, I32 type)
9316 char *s = scan_str(start,FALSE,FALSE);
9319 char * const delimiter = skipspace(start);
9320 Perl_croak(aTHX_ *delimiter == '?'
9321 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9322 : "Search pattern not terminated" );
9325 pm = (PMOP*)newPMOP(type, 0);
9326 if (PL_multi_open == '?')
9327 pm->op_pmflags |= PMf_ONCE;
9329 while (*s && strchr("iomsx", *s))
9330 pmflag(&pm->op_pmflags,*s++);
9333 while (*s && strchr("iogcmsx", *s))
9334 pmflag(&pm->op_pmflags,*s++);
9336 /* issue a warning if /c is specified,but /g is not */
9337 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9338 && ckWARN(WARN_REGEXP))
9340 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
9343 pm->op_pmpermflags = pm->op_pmflags;
9345 PL_lex_op = (OP*)pm;
9346 yylval.ival = OP_MATCH;
9351 S_scan_subst(pTHX_ char *start)
9359 yylval.ival = OP_NULL;
9361 s = scan_str(start,FALSE,FALSE);
9364 Perl_croak(aTHX_ "Substitution pattern not terminated");
9366 if (s[-1] == PL_multi_open)
9369 first_start = PL_multi_start;
9370 s = scan_str(s,FALSE,FALSE);
9373 SvREFCNT_dec(PL_lex_stuff);
9374 PL_lex_stuff = Nullsv;
9376 Perl_croak(aTHX_ "Substitution replacement not terminated");
9378 PL_multi_start = first_start; /* so whole substitution is taken together */
9380 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9386 else if (strchr("iogcmsx", *s))
9387 pmflag(&pm->op_pmflags,*s++);
9392 /* /c is not meaningful with s/// */
9393 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP))
9395 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
9400 PL_sublex_info.super_bufptr = s;
9401 PL_sublex_info.super_bufend = PL_bufend;
9403 pm->op_pmflags |= PMf_EVAL;
9404 repl = newSVpvn("",0);
9406 sv_catpv(repl, es ? "eval " : "do ");
9407 sv_catpvn(repl, "{ ", 2);
9408 sv_catsv(repl, PL_lex_repl);
9409 sv_catpvn(repl, " };", 2);
9411 SvREFCNT_dec(PL_lex_repl);
9415 pm->op_pmpermflags = pm->op_pmflags;
9416 PL_lex_op = (OP*)pm;
9417 yylval.ival = OP_SUBST;
9422 S_scan_trans(pTHX_ char *start)
9431 yylval.ival = OP_NULL;
9433 s = scan_str(start,FALSE,FALSE);
9435 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9436 if (s[-1] == PL_multi_open)
9439 s = scan_str(s,FALSE,FALSE);
9442 SvREFCNT_dec(PL_lex_stuff);
9443 PL_lex_stuff = Nullsv;
9445 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9448 complement = del = squash = 0;
9452 complement = OPpTRANS_COMPLEMENT;
9455 del = OPpTRANS_DELETE;
9458 squash = OPpTRANS_SQUASH;
9467 Newx(tbl, complement&&!del?258:256, short);
9468 o = newPVOP(OP_TRANS, 0, (char*)tbl);
9469 o->op_private &= ~OPpTRANS_ALL;
9470 o->op_private |= del|squash|complement|
9471 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9472 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9475 yylval.ival = OP_TRANS;
9480 S_scan_heredoc(pTHX_ register char *s)
9483 I32 op_type = OP_SCALAR;
9487 const char newline[] = "\n";
9488 const char *found_newline;
9492 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9496 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9499 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9500 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9503 s = delimcpy(d, e, s, PL_bufend, term, &len);
9513 if (!isALNUM_lazy_if(s,UTF))
9514 deprecate_old("bare << to mean <<\"\"");
9515 for (; isALNUM_lazy_if(s,UTF); s++) {
9520 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9521 Perl_croak(aTHX_ "Delimiter for here document is too long");
9524 len = d - PL_tokenbuf;
9525 #ifndef PERL_STRICT_CR
9526 d = strchr(s, '\r');
9528 char * const olds = s;
9530 while (s < PL_bufend) {
9536 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9545 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9549 if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) {
9550 herewas = newSVpvn(s,PL_bufend-s);
9554 herewas = newSVpvn(s,found_newline-s);
9556 s += SvCUR(herewas);
9558 tmpstr = NEWSV(87,79);
9559 sv_upgrade(tmpstr, SVt_PVIV);
9562 SvIV_set(tmpstr, -1);
9564 else if (term == '`') {
9565 op_type = OP_BACKTICK;
9566 SvIV_set(tmpstr, '\\');
9570 PL_multi_start = CopLINE(PL_curcop);
9571 PL_multi_open = PL_multi_close = '<';
9572 term = *PL_tokenbuf;
9573 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9574 char *bufptr = PL_sublex_info.super_bufptr;
9575 char *bufend = PL_sublex_info.super_bufend;
9576 char * const olds = s - SvCUR(herewas);
9577 s = strchr(bufptr, '\n');
9581 while (s < bufend &&
9582 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9584 CopLINE_inc(PL_curcop);
9587 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9588 missingterm(PL_tokenbuf);
9590 sv_setpvn(herewas,bufptr,d-bufptr+1);
9591 sv_setpvn(tmpstr,d+1,s-d);
9593 sv_catpvn(herewas,s,bufend-s);
9594 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9601 while (s < PL_bufend &&
9602 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9604 CopLINE_inc(PL_curcop);
9606 if (s >= PL_bufend) {
9607 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9608 missingterm(PL_tokenbuf);
9610 sv_setpvn(tmpstr,d+1,s-d);
9612 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9614 sv_catpvn(herewas,s,PL_bufend-s);
9615 sv_setsv(PL_linestr,herewas);
9616 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9617 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9618 PL_last_lop = PL_last_uni = Nullch;
9621 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
9622 while (s >= PL_bufend) { /* multiple line string? */
9624 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9625 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9626 missingterm(PL_tokenbuf);
9628 CopLINE_inc(PL_curcop);
9629 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9630 PL_last_lop = PL_last_uni = Nullch;
9631 #ifndef PERL_STRICT_CR
9632 if (PL_bufend - PL_linestart >= 2) {
9633 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9634 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9636 PL_bufend[-2] = '\n';
9638 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9640 else if (PL_bufend[-1] == '\r')
9641 PL_bufend[-1] = '\n';
9643 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9644 PL_bufend[-1] = '\n';
9646 if (PERLDB_LINE && PL_curstash != PL_debstash) {
9647 SV *sv = NEWSV(88,0);
9649 sv_upgrade(sv, SVt_PVMG);
9650 sv_setsv(sv,PL_linestr);
9653 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9655 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9656 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9657 *(SvPVX(PL_linestr) + off ) = ' ';
9658 sv_catsv(PL_linestr,herewas);
9659 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9660 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9664 sv_catsv(tmpstr,PL_linestr);
9669 PL_multi_end = CopLINE(PL_curcop);
9670 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9671 SvPV_shrink_to_cur(tmpstr);
9673 SvREFCNT_dec(herewas);
9675 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9677 else if (PL_encoding)
9678 sv_recode_to_utf8(tmpstr, PL_encoding);
9680 PL_lex_stuff = tmpstr;
9681 yylval.ival = op_type;
9686 takes: current position in input buffer
9687 returns: new position in input buffer
9688 side-effects: yylval and lex_op are set.
9693 <FH> read from filehandle
9694 <pkg::FH> read from package qualified filehandle
9695 <pkg'FH> read from package qualified filehandle
9696 <$fh> read from filehandle in $fh
9702 S_scan_inputsymbol(pTHX_ char *start)
9704 register char *s = start; /* current position in buffer */
9710 d = PL_tokenbuf; /* start of temp holding space */
9711 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9712 end = strchr(s, '\n');
9715 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9717 /* die if we didn't have space for the contents of the <>,
9718 or if it didn't end, or if we see a newline
9721 if (len >= sizeof PL_tokenbuf)
9722 Perl_croak(aTHX_ "Excessively long <> operator");
9724 Perl_croak(aTHX_ "Unterminated <> operator");
9729 Remember, only scalar variables are interpreted as filehandles by
9730 this code. Anything more complex (e.g., <$fh{$num}>) will be
9731 treated as a glob() call.
9732 This code makes use of the fact that except for the $ at the front,
9733 a scalar variable and a filehandle look the same.
9735 if (*d == '$' && d[1]) d++;
9737 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9738 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9741 /* If we've tried to read what we allow filehandles to look like, and
9742 there's still text left, then it must be a glob() and not a getline.
9743 Use scan_str to pull out the stuff between the <> and treat it
9744 as nothing more than a string.
9747 if (d - PL_tokenbuf != len) {
9748 yylval.ival = OP_GLOB;
9750 s = scan_str(start,FALSE,FALSE);
9752 Perl_croak(aTHX_ "Glob not terminated");
9756 bool readline_overriden = FALSE;
9757 GV *gv_readline = Nullgv;
9759 /* we're in a filehandle read situation */
9762 /* turn <> into <ARGV> */
9764 Copy("ARGV",d,5,char);
9766 /* Check whether readline() is overriden */
9767 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9768 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9770 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9771 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9772 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9773 readline_overriden = TRUE;
9775 /* if <$fh>, create the ops to turn the variable into a
9781 /* try to find it in the pad for this block, otherwise find
9782 add symbol table ops
9784 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9785 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9786 HV *stash = PAD_COMPNAME_OURSTASH(tmp);
9787 HEK *stashname = HvNAME_HEK(stash);
9788 SV *sym = sv_2mortal(newSVhek(stashname));
9789 sv_catpvn(sym, "::", 2);
9795 OP *o = newOP(OP_PADSV, 0);
9797 PL_lex_op = readline_overriden
9798 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9799 append_elem(OP_LIST, o,
9800 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9801 : (OP*)newUNOP(OP_READLINE, 0, o);
9810 ? (GV_ADDMULTI | GV_ADDINEVAL)
9813 PL_lex_op = readline_overriden
9814 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9815 append_elem(OP_LIST,
9816 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9817 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9818 : (OP*)newUNOP(OP_READLINE, 0,
9819 newUNOP(OP_RV2SV, 0,
9820 newGVOP(OP_GV, 0, gv)));
9822 if (!readline_overriden)
9823 PL_lex_op->op_flags |= OPf_SPECIAL;
9824 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9825 yylval.ival = OP_NULL;
9828 /* If it's none of the above, it must be a literal filehandle
9829 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9831 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9832 PL_lex_op = readline_overriden
9833 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9834 append_elem(OP_LIST,
9835 newGVOP(OP_GV, 0, gv),
9836 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9837 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9838 yylval.ival = OP_NULL;
9847 takes: start position in buffer
9848 keep_quoted preserve \ on the embedded delimiter(s)
9849 keep_delims preserve the delimiters around the string
9850 returns: position to continue reading from buffer
9851 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9852 updates the read buffer.
9854 This subroutine pulls a string out of the input. It is called for:
9855 q single quotes q(literal text)
9856 ' single quotes 'literal text'
9857 qq double quotes qq(interpolate $here please)
9858 " double quotes "interpolate $here please"
9859 qx backticks qx(/bin/ls -l)
9860 ` backticks `/bin/ls -l`
9861 qw quote words @EXPORT_OK = qw( func() $spam )
9862 m// regexp match m/this/
9863 s/// regexp substitute s/this/that/
9864 tr/// string transliterate tr/this/that/
9865 y/// string transliterate y/this/that/
9866 ($*@) sub prototypes sub foo ($)
9867 (stuff) sub attr parameters sub foo : attr(stuff)
9868 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9870 In most of these cases (all but <>, patterns and transliterate)
9871 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9872 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9873 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9876 It skips whitespace before the string starts, and treats the first
9877 character as the delimiter. If the delimiter is one of ([{< then
9878 the corresponding "close" character )]}> is used as the closing
9879 delimiter. It allows quoting of delimiters, and if the string has
9880 balanced delimiters ([{<>}]) it allows nesting.
9882 On success, the SV with the resulting string is put into lex_stuff or,
9883 if that is already non-NULL, into lex_repl. The second case occurs only
9884 when parsing the RHS of the special constructs s/// and tr/// (y///).
9885 For convenience, the terminating delimiter character is stuffed into
9890 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9892 SV *sv; /* scalar value: string */
9893 char *tmps; /* temp string, used for delimiter matching */
9894 register char *s = start; /* current position in the buffer */
9895 register char term; /* terminating character */
9896 register char *to; /* current position in the sv's data */
9897 I32 brackets = 1; /* bracket nesting level */
9898 bool has_utf8 = FALSE; /* is there any utf8 content? */
9899 I32 termcode; /* terminating char. code */
9900 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9901 STRLEN termlen; /* length of terminating string */
9902 char *last = NULL; /* last position for nesting bracket */
9904 /* skip space before the delimiter */
9908 /* mark where we are, in case we need to report errors */
9911 /* after skipping whitespace, the next character is the terminator */
9914 termcode = termstr[0] = term;
9918 termcode = utf8_to_uvchr((U8*)s, &termlen);
9919 Copy(s, termstr, termlen, U8);
9920 if (!UTF8_IS_INVARIANT(term))
9924 /* mark where we are */
9925 PL_multi_start = CopLINE(PL_curcop);
9926 PL_multi_open = term;
9928 /* find corresponding closing delimiter */
9929 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9930 termcode = termstr[0] = term = tmps[5];
9932 PL_multi_close = term;
9934 /* create a new SV to hold the contents. 87 is leak category, I'm
9935 assuming. 79 is the SV's initial length. What a random number. */
9937 sv_upgrade(sv, SVt_PVIV);
9938 SvIV_set(sv, termcode);
9939 (void)SvPOK_only(sv); /* validate pointer */
9941 /* move past delimiter and try to read a complete string */
9943 sv_catpvn(sv, s, termlen);
9946 if (PL_encoding && !UTF) {
9950 int offset = s - SvPVX_const(PL_linestr);
9951 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9952 &offset, (char*)termstr, termlen);
9953 const char *ns = SvPVX_const(PL_linestr) + offset;
9954 char *svlast = SvEND(sv) - 1;
9956 for (; s < ns; s++) {
9957 if (*s == '\n' && !PL_rsfp)
9958 CopLINE_inc(PL_curcop);
9961 goto read_more_line;
9963 /* handle quoted delimiters */
9964 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9966 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9968 if ((svlast-1 - t) % 2) {
9972 SvCUR_set(sv, SvCUR(sv) - 1);
9977 if (PL_multi_open == PL_multi_close) {
9985 for (t = w = last; t < svlast; w++, t++) {
9986 /* At here, all closes are "was quoted" one,
9987 so we don't check PL_multi_close. */
9989 if (!keep_quoted && *(t+1) == PL_multi_open)
9994 else if (*t == PL_multi_open)
10002 SvCUR_set(sv, w - SvPVX_const(sv));
10005 if (--brackets <= 0)
10010 if (!keep_delims) {
10011 SvCUR_set(sv, SvCUR(sv) - 1);
10017 /* extend sv if need be */
10018 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10019 /* set 'to' to the next character in the sv's string */
10020 to = SvPVX(sv)+SvCUR(sv);
10022 /* if open delimiter is the close delimiter read unbridle */
10023 if (PL_multi_open == PL_multi_close) {
10024 for (; s < PL_bufend; s++,to++) {
10025 /* embedded newlines increment the current line number */
10026 if (*s == '\n' && !PL_rsfp)
10027 CopLINE_inc(PL_curcop);
10028 /* handle quoted delimiters */
10029 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10030 if (!keep_quoted && s[1] == term)
10032 /* any other quotes are simply copied straight through */
10036 /* terminate when run out of buffer (the for() condition), or
10037 have found the terminator */
10038 else if (*s == term) {
10041 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10044 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10050 /* if the terminator isn't the same as the start character (e.g.,
10051 matched brackets), we have to allow more in the quoting, and
10052 be prepared for nested brackets.
10055 /* read until we run out of string, or we find the terminator */
10056 for (; s < PL_bufend; s++,to++) {
10057 /* embedded newlines increment the line count */
10058 if (*s == '\n' && !PL_rsfp)
10059 CopLINE_inc(PL_curcop);
10060 /* backslashes can escape the open or closing characters */
10061 if (*s == '\\' && s+1 < PL_bufend) {
10062 if (!keep_quoted &&
10063 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10068 /* allow nested opens and closes */
10069 else if (*s == PL_multi_close && --brackets <= 0)
10071 else if (*s == PL_multi_open)
10073 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10078 /* terminate the copied string and update the sv's end-of-string */
10080 SvCUR_set(sv, to - SvPVX_const(sv));
10083 * this next chunk reads more into the buffer if we're not done yet
10087 break; /* handle case where we are done yet :-) */
10089 #ifndef PERL_STRICT_CR
10090 if (to - SvPVX_const(sv) >= 2) {
10091 if ((to[-2] == '\r' && to[-1] == '\n') ||
10092 (to[-2] == '\n' && to[-1] == '\r'))
10096 SvCUR_set(sv, to - SvPVX_const(sv));
10098 else if (to[-1] == '\r')
10101 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10106 /* if we're out of file, or a read fails, bail and reset the current
10107 line marker so we can report where the unterminated string began
10110 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10112 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10115 /* we read a line, so increment our line counter */
10116 CopLINE_inc(PL_curcop);
10118 /* update debugger info */
10119 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10120 SV *sv = NEWSV(88,0);
10122 sv_upgrade(sv, SVt_PVMG);
10123 sv_setsv(sv,PL_linestr);
10124 (void)SvIOK_on(sv);
10126 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10129 /* having changed the buffer, we must update PL_bufend */
10130 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10131 PL_last_lop = PL_last_uni = Nullch;
10134 /* at this point, we have successfully read the delimited string */
10136 if (!PL_encoding || UTF) {
10138 sv_catpvn(sv, s, termlen);
10141 if (has_utf8 || PL_encoding)
10144 PL_multi_end = CopLINE(PL_curcop);
10146 /* if we allocated too much space, give some back */
10147 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10148 SvLEN_set(sv, SvCUR(sv) + 1);
10149 SvPV_renew(sv, SvLEN(sv));
10152 /* decide whether this is the first or second quoted string we've read
10165 takes: pointer to position in buffer
10166 returns: pointer to new position in buffer
10167 side-effects: builds ops for the constant in yylval.op
10169 Read a number in any of the formats that Perl accepts:
10171 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10172 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10175 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10177 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10180 If it reads a number without a decimal point or an exponent, it will
10181 try converting the number to an integer and see if it can do so
10182 without loss of precision.
10186 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10188 register const char *s = start; /* current position in buffer */
10189 register char *d; /* destination in temp buffer */
10190 register char *e; /* end of temp buffer */
10191 NV nv; /* number read, as a double */
10192 SV *sv = Nullsv; /* place to put the converted number */
10193 bool floatit; /* boolean: int or float? */
10194 const char *lastub = 0; /* position of last underbar */
10195 static char const number_too_long[] = "Number too long";
10197 /* We use the first character to decide what type of number this is */
10201 Perl_croak(aTHX_ "panic: scan_num");
10203 /* if it starts with a 0, it could be an octal number, a decimal in
10204 0.13 disguise, or a hexadecimal number, or a binary number. */
10208 u holds the "number so far"
10209 shift the power of 2 of the base
10210 (hex == 4, octal == 3, binary == 1)
10211 overflowed was the number more than we can hold?
10213 Shift is used when we add a digit. It also serves as an "are
10214 we in octal/hex/binary?" indicator to disallow hex characters
10215 when in octal mode.
10220 bool overflowed = FALSE;
10221 bool just_zero = TRUE; /* just plain 0 or binary number? */
10222 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10223 static const char* const bases[5] =
10224 { "", "binary", "", "octal", "hexadecimal" };
10225 static const char* const Bases[5] =
10226 { "", "Binary", "", "Octal", "Hexadecimal" };
10227 static const char* const maxima[5] =
10229 "0b11111111111111111111111111111111",
10233 const char *base, *Base, *max;
10235 /* check for hex */
10240 } else if (s[1] == 'b') {
10245 /* check for a decimal in disguise */
10246 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10248 /* so it must be octal */
10255 if (ckWARN(WARN_SYNTAX))
10256 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10257 "Misplaced _ in number");
10261 base = bases[shift];
10262 Base = Bases[shift];
10263 max = maxima[shift];
10265 /* read the rest of the number */
10267 /* x is used in the overflow test,
10268 b is the digit we're adding on. */
10273 /* if we don't mention it, we're done */
10277 /* _ are ignored -- but warned about if consecutive */
10279 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10280 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10281 "Misplaced _ in number");
10285 /* 8 and 9 are not octal */
10286 case '8': case '9':
10288 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10292 case '2': case '3': case '4':
10293 case '5': case '6': case '7':
10295 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10298 case '0': case '1':
10299 b = *s++ & 15; /* ASCII digit -> value of digit */
10303 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10304 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10305 /* make sure they said 0x */
10308 b = (*s++ & 7) + 9;
10310 /* Prepare to put the digit we have onto the end
10311 of the number so far. We check for overflows.
10317 x = u << shift; /* make room for the digit */
10319 if ((x >> shift) != u
10320 && !(PL_hints & HINT_NEW_BINARY)) {
10323 if (ckWARN_d(WARN_OVERFLOW))
10324 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10325 "Integer overflow in %s number",
10328 u = x | b; /* add the digit to the end */
10331 n *= nvshift[shift];
10332 /* If an NV has not enough bits in its
10333 * mantissa to represent an UV this summing of
10334 * small low-order numbers is a waste of time
10335 * (because the NV cannot preserve the
10336 * low-order bits anyway): we could just
10337 * remember when did we overflow and in the
10338 * end just multiply n by the right
10346 /* if we get here, we had success: make a scalar value from
10351 /* final misplaced underbar check */
10352 if (s[-1] == '_') {
10353 if (ckWARN(WARN_SYNTAX))
10354 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10359 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10360 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10361 "%s number > %s non-portable",
10367 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10368 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10369 "%s number > %s non-portable",
10374 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10375 sv = new_constant(start, s - start, "integer",
10377 else if (PL_hints & HINT_NEW_BINARY)
10378 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10383 handle decimal numbers.
10384 we're also sent here when we read a 0 as the first digit
10386 case '1': case '2': case '3': case '4': case '5':
10387 case '6': case '7': case '8': case '9': case '.':
10390 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10393 /* read next group of digits and _ and copy into d */
10394 while (isDIGIT(*s) || *s == '_') {
10395 /* skip underscores, checking for misplaced ones
10399 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10400 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10401 "Misplaced _ in number");
10405 /* check for end of fixed-length buffer */
10407 Perl_croak(aTHX_ number_too_long);
10408 /* if we're ok, copy the character */
10413 /* final misplaced underbar check */
10414 if (lastub && s == lastub + 1) {
10415 if (ckWARN(WARN_SYNTAX))
10416 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10419 /* read a decimal portion if there is one. avoid
10420 3..5 being interpreted as the number 3. followed
10423 if (*s == '.' && s[1] != '.') {
10428 if (ckWARN(WARN_SYNTAX))
10429 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10430 "Misplaced _ in number");
10434 /* copy, ignoring underbars, until we run out of digits.
10436 for (; isDIGIT(*s) || *s == '_'; s++) {
10437 /* fixed length buffer check */
10439 Perl_croak(aTHX_ number_too_long);
10441 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10442 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10443 "Misplaced _ in number");
10449 /* fractional part ending in underbar? */
10450 if (s[-1] == '_') {
10451 if (ckWARN(WARN_SYNTAX))
10452 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10453 "Misplaced _ in number");
10455 if (*s == '.' && isDIGIT(s[1])) {
10456 /* oops, it's really a v-string, but without the "v" */
10462 /* read exponent part, if present */
10463 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10467 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10468 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10470 /* stray preinitial _ */
10472 if (ckWARN(WARN_SYNTAX))
10473 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10474 "Misplaced _ in number");
10478 /* allow positive or negative exponent */
10479 if (*s == '+' || *s == '-')
10482 /* stray initial _ */
10484 if (ckWARN(WARN_SYNTAX))
10485 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10486 "Misplaced _ in number");
10490 /* read digits of exponent */
10491 while (isDIGIT(*s) || *s == '_') {
10494 Perl_croak(aTHX_ number_too_long);
10498 if (((lastub && s == lastub + 1) ||
10499 (!isDIGIT(s[1]) && s[1] != '_'))
10500 && ckWARN(WARN_SYNTAX))
10501 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10502 "Misplaced _ in number");
10509 /* make an sv from the string */
10513 We try to do an integer conversion first if no characters
10514 indicating "float" have been found.
10519 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10521 if (flags == IS_NUMBER_IN_UV) {
10523 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10526 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10527 if (uv <= (UV) IV_MIN)
10528 sv_setiv(sv, -(IV)uv);
10535 /* terminate the string */
10537 nv = Atof(PL_tokenbuf);
10541 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10542 (PL_hints & HINT_NEW_INTEGER) )
10543 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10544 (floatit ? "float" : "integer"),
10548 /* if it starts with a v, it could be a v-string */
10551 sv = NEWSV(92,5); /* preallocate storage space */
10552 s = scan_vstring(s,sv);
10556 /* make the op for the constant and return */
10559 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10561 lvalp->opval = Nullop;
10567 S_scan_formline(pTHX_ register char *s)
10569 register char *eol;
10571 SV *stuff = newSVpvn("",0);
10572 bool needargs = FALSE;
10573 bool eofmt = FALSE;
10575 while (!needargs) {
10577 #ifdef PERL_STRICT_CR
10578 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10580 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10582 if (*t == '\n' || t == PL_bufend) {
10587 if (PL_in_eval && !PL_rsfp) {
10588 eol = (char *) memchr(s,'\n',PL_bufend-s);
10593 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10595 for (t = s; t < eol; t++) {
10596 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10598 goto enough; /* ~~ must be first line in formline */
10600 if (*t == '@' || *t == '^')
10604 sv_catpvn(stuff, s, eol-s);
10605 #ifndef PERL_STRICT_CR
10606 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10607 char *end = SvPVX(stuff) + SvCUR(stuff);
10610 SvCUR_set(stuff, SvCUR(stuff) - 1);
10619 s = filter_gets(PL_linestr, PL_rsfp, 0);
10620 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10621 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10622 PL_last_lop = PL_last_uni = Nullch;
10631 if (SvCUR(stuff)) {
10634 PL_lex_state = LEX_NORMAL;
10635 PL_nextval[PL_nexttoke].ival = 0;
10639 PL_lex_state = LEX_FORMLINE;
10641 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10643 else if (PL_encoding)
10644 sv_recode_to_utf8(stuff, PL_encoding);
10646 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10648 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10652 SvREFCNT_dec(stuff);
10654 PL_lex_formbrack = 0;
10665 PL_cshlen = strlen(PL_cshname);
10670 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10672 const I32 oldsavestack_ix = PL_savestack_ix;
10673 CV* outsidecv = PL_compcv;
10676 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10678 SAVEI32(PL_subline);
10679 save_item(PL_subname);
10680 SAVESPTR(PL_compcv);
10682 PL_compcv = (CV*)NEWSV(1104,0);
10683 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10684 CvFLAGS(PL_compcv) |= flags;
10686 PL_subline = CopLINE(PL_curcop);
10687 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10688 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10689 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10691 return oldsavestack_ix;
10695 #pragma segment Perl_yylex
10698 Perl_yywarn(pTHX_ const char *s)
10700 PL_in_eval |= EVAL_WARNONLY;
10702 PL_in_eval &= ~EVAL_WARNONLY;
10707 Perl_yyerror(pTHX_ const char *s)
10709 const char *where = NULL;
10710 const char *context = NULL;
10714 if (!yychar || (yychar == ';' && !PL_rsfp))
10716 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10717 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10718 PL_oldbufptr != PL_bufptr) {
10721 The code below is removed for NetWare because it abends/crashes on NetWare
10722 when the script has error such as not having the closing quotes like:
10723 if ($var eq "value)
10724 Checking of white spaces is anyway done in NetWare code.
10727 while (isSPACE(*PL_oldoldbufptr))
10730 context = PL_oldoldbufptr;
10731 contlen = PL_bufptr - PL_oldoldbufptr;
10733 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10734 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10737 The code below is removed for NetWare because it abends/crashes on NetWare
10738 when the script has error such as not having the closing quotes like:
10739 if ($var eq "value)
10740 Checking of white spaces is anyway done in NetWare code.
10743 while (isSPACE(*PL_oldbufptr))
10746 context = PL_oldbufptr;
10747 contlen = PL_bufptr - PL_oldbufptr;
10749 else if (yychar > 255)
10750 where = "next token ???";
10751 else if (yychar == -2) { /* YYEMPTY */
10752 if (PL_lex_state == LEX_NORMAL ||
10753 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10754 where = "at end of line";
10755 else if (PL_lex_inpat)
10756 where = "within pattern";
10758 where = "within string";
10761 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10763 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10764 else if (isPRINT_LC(yychar))
10765 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10767 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10768 where = SvPVX_const(where_sv);
10770 msg = sv_2mortal(newSVpv(s, 0));
10771 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10772 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10774 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10776 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10777 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10778 Perl_sv_catpvf(aTHX_ msg,
10779 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10780 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10783 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10784 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10787 if (PL_error_count >= 10) {
10788 if (PL_in_eval && SvCUR(ERRSV))
10789 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10790 ERRSV, OutCopFILE(PL_curcop));
10792 Perl_croak(aTHX_ "%s has too many errors.\n",
10793 OutCopFILE(PL_curcop));
10796 PL_in_my_stash = Nullhv;
10800 #pragma segment Main
10804 S_swallow_bom(pTHX_ U8 *s)
10806 const STRLEN slen = SvCUR(PL_linestr);
10809 if (s[1] == 0xFE) {
10810 /* UTF-16 little-endian? (or UTF32-LE?) */
10811 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10812 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10813 #ifndef PERL_NO_UTF16_FILTER
10814 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10817 if (PL_bufend > (char*)s) {
10821 filter_add(utf16rev_textfilter, NULL);
10822 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10823 utf16_to_utf8_reversed(s, news,
10824 PL_bufend - (char*)s - 1,
10826 sv_setpvn(PL_linestr, (const char*)news, newlen);
10828 SvUTF8_on(PL_linestr);
10829 s = (U8*)SvPVX(PL_linestr);
10830 PL_bufend = SvPVX(PL_linestr) + newlen;
10833 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10838 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10839 #ifndef PERL_NO_UTF16_FILTER
10840 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10843 if (PL_bufend > (char *)s) {
10847 filter_add(utf16_textfilter, NULL);
10848 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10849 utf16_to_utf8(s, news,
10850 PL_bufend - (char*)s,
10852 sv_setpvn(PL_linestr, (const char*)news, newlen);
10854 SvUTF8_on(PL_linestr);
10855 s = (U8*)SvPVX(PL_linestr);
10856 PL_bufend = SvPVX(PL_linestr) + newlen;
10859 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
10864 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10865 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10866 s += 3; /* UTF-8 */
10872 if (s[2] == 0xFE && s[3] == 0xFF) {
10873 /* UTF-32 big-endian */
10874 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
10877 else if (s[2] == 0 && s[3] != 0) {
10880 * are a good indicator of UTF-16BE. */
10881 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10886 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10889 * are a good indicator of UTF-16LE. */
10890 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10899 * Restore a source filter.
10903 restore_rsfp(pTHX_ void *f)
10905 PerlIO *fp = (PerlIO*)f;
10907 if (PL_rsfp == PerlIO_stdin())
10908 PerlIO_clearerr(PL_rsfp);
10909 else if (PL_rsfp && (PL_rsfp != fp))
10910 PerlIO_close(PL_rsfp);
10914 #ifndef PERL_NO_UTF16_FILTER
10916 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10918 const STRLEN old = SvCUR(sv);
10919 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10920 DEBUG_P(PerlIO_printf(Perl_debug_log,
10921 "utf16_textfilter(%p): %d %d (%d)\n",
10922 utf16_textfilter, idx, maxlen, (int) count));
10926 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10927 Copy(SvPVX_const(sv), tmps, old, char);
10928 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10929 SvCUR(sv) - old, &newlen);
10930 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10932 DEBUG_P({sv_dump(sv);});
10937 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10939 const STRLEN old = SvCUR(sv);
10940 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10941 DEBUG_P(PerlIO_printf(Perl_debug_log,
10942 "utf16rev_textfilter(%p): %d %d (%d)\n",
10943 utf16rev_textfilter, idx, maxlen, (int) count));
10947 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10948 Copy(SvPVX_const(sv), tmps, old, char);
10949 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10950 SvCUR(sv) - old, &newlen);
10951 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10953 DEBUG_P({ sv_dump(sv); });
10959 Returns a pointer to the next character after the parsed
10960 vstring, as well as updating the passed in sv.
10962 Function must be called like
10965 s = scan_vstring(s,sv);
10967 The sv should already be large enough to store the vstring
10968 passed in, for performance reasons.
10973 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
10975 const char *pos = s;
10976 const char *start = s;
10977 if (*pos == 'v') pos++; /* get past 'v' */
10978 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
10980 if ( *pos != '.') {
10981 /* this may not be a v-string if followed by => */
10982 const char *next = pos;
10983 while (next < PL_bufend && isSPACE(*next))
10985 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
10986 /* return string not v-string */
10987 sv_setpvn(sv,(char *)s,pos-s);
10988 return (char *)pos;
10992 if (!isALPHA(*pos)) {
10994 U8 tmpbuf[UTF8_MAXBYTES+1];
10997 if (*s == 'v') s++; /* get past 'v' */
10999 sv_setpvn(sv, "", 0);
11004 /* this is atoi() that tolerates underscores */
11005 const char *end = pos;
11007 while (--end >= s) {
11012 rev += (*end - '0') * mult;
11014 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11015 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11016 "Integer overflow in decimal number");
11020 if (rev > 0x7FFFFFFF)
11021 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11023 /* Append native character for the rev point */
11024 tmpend = uvchr_to_utf8(tmpbuf, rev);
11025 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11026 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11028 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11034 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11038 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11046 * c-indentation-style: bsd
11047 * c-basic-offset: 4
11048 * indent-tabs-mode: t
11051 * ex: set ts=8 sts=4 sw=4 noet: