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 */
667 const char *cf = CopFILE(PL_curcop);
668 if (cf && strlen(cf) > 7 && strnEQ(cf, "(eval ", 6)) {
669 /* must copy *{"::_<(eval N)[oldfilename:L]"}
670 * to *{"::_<newfilename"} */
671 char smallbuf[256], smallbuf2[256];
672 char *tmpbuf, *tmpbuf2;
674 STRLEN tmplen = strlen(cf);
675 STRLEN tmplen2 = strlen(s);
676 if (tmplen + 3 < sizeof smallbuf)
679 Newx(tmpbuf, tmplen + 3, char);
680 if (tmplen2 + 3 < sizeof smallbuf2)
683 Newx(tmpbuf2, tmplen2 + 3, char);
684 tmpbuf[0] = tmpbuf2[0] = '_';
685 tmpbuf[1] = tmpbuf2[1] = '<';
686 memcpy(tmpbuf + 2, cf, ++tmplen);
687 memcpy(tmpbuf2 + 2, s, ++tmplen2);
689 gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
690 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
692 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
693 /* adjust ${"::_<newfilename"} to store the new file name */
694 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
695 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(gv));
696 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(gv));
697 if (tmpbuf != smallbuf) Safefree(tmpbuf);
698 if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
700 CopFILE_free(PL_curcop);
701 CopFILE_set(PL_curcop, s);
704 CopLINE_set(PL_curcop, atoi(n)-1);
709 * Called to gobble the appropriate amount and type of whitespace.
710 * Skips comments as well.
714 S_skipspace(pTHX_ register char *s)
716 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
717 while (s < PL_bufend && SPACE_OR_TAB(*s))
723 SSize_t oldprevlen, oldoldprevlen;
724 SSize_t oldloplen = 0, oldunilen = 0;
725 while (s < PL_bufend && isSPACE(*s)) {
726 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
731 if (s < PL_bufend && *s == '#') {
732 while (s < PL_bufend && *s != '\n')
736 if (PL_in_eval && !PL_rsfp) {
743 /* only continue to recharge the buffer if we're at the end
744 * of the buffer, we're not reading from a source filter, and
745 * we're in normal lexing mode
747 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
748 PL_lex_state == LEX_FORMLINE)
751 /* try to recharge the buffer */
752 if ((s = filter_gets(PL_linestr, PL_rsfp,
753 (prevlen = SvCUR(PL_linestr)))) == Nullch)
755 /* end of file. Add on the -p or -n magic */
758 ";}continue{print or die qq(-p destination: $!\\n);}");
759 PL_minus_n = PL_minus_p = 0;
761 else if (PL_minus_n) {
762 sv_setpvn(PL_linestr, ";}", 2);
766 sv_setpvn(PL_linestr,";", 1);
768 /* reset variables for next time we lex */
769 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
771 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
772 PL_last_lop = PL_last_uni = Nullch;
774 /* Close the filehandle. Could be from -P preprocessor,
775 * STDIN, or a regular file. If we were reading code from
776 * STDIN (because the commandline held no -e or filename)
777 * then we don't close it, we reset it so the code can
778 * read from STDIN too.
781 if (PL_preprocess && !PL_in_eval)
782 (void)PerlProc_pclose(PL_rsfp);
783 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
784 PerlIO_clearerr(PL_rsfp);
786 (void)PerlIO_close(PL_rsfp);
791 /* not at end of file, so we only read another line */
792 /* make corresponding updates to old pointers, for yyerror() */
793 oldprevlen = PL_oldbufptr - PL_bufend;
794 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
796 oldunilen = PL_last_uni - PL_bufend;
798 oldloplen = PL_last_lop - PL_bufend;
799 PL_linestart = PL_bufptr = s + prevlen;
800 PL_bufend = s + SvCUR(PL_linestr);
802 PL_oldbufptr = s + oldprevlen;
803 PL_oldoldbufptr = s + oldoldprevlen;
805 PL_last_uni = s + oldunilen;
807 PL_last_lop = s + oldloplen;
810 /* debugger active and we're not compiling the debugger code,
811 * so store the line into the debugger's array of lines
813 if (PERLDB_LINE && PL_curstash != PL_debstash) {
814 SV * const sv = NEWSV(85,0);
816 sv_upgrade(sv, SVt_PVMG);
817 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
820 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
827 * Check the unary operators to ensure there's no ambiguity in how they're
828 * used. An ambiguous piece of code would be:
830 * This doesn't mean rand() + 5. Because rand() is a unary operator,
831 * the +5 is its argument.
840 if (PL_oldoldbufptr != PL_last_uni)
842 while (isSPACE(*PL_last_uni))
844 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
845 if ((t = strchr(s, '(')) && t < PL_bufptr)
847 if (ckWARN_d(WARN_AMBIGUOUS)){
850 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
851 "Warning: Use of \"%s\" without parentheses is ambiguous",
858 * LOP : macro to build a list operator. Its behaviour has been replaced
859 * with a subroutine, S_lop() for which LOP is just another name.
862 #define LOP(f,x) return lop(f,x,s)
866 * Build a list operator (or something that might be one). The rules:
867 * - if we have a next token, then it's a list operator [why?]
868 * - if the next thing is an opening paren, then it's a function
869 * - else it's a list operator
873 S_lop(pTHX_ I32 f, int x, char *s)
879 PL_last_lop = PL_oldbufptr;
880 PL_last_lop_op = (OPCODE)f;
882 return REPORT(LSTOP);
889 return REPORT(LSTOP);
894 * When the lexer realizes it knows the next token (for instance,
895 * it is reordering tokens for the parser) then it can call S_force_next
896 * to know what token to return the next time the lexer is called. Caller
897 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
898 * handles the token correctly.
902 S_force_next(pTHX_ I32 type)
904 PL_nexttype[PL_nexttoke] = type;
906 if (PL_lex_state != LEX_KNOWNEXT) {
907 PL_lex_defer = PL_lex_state;
908 PL_lex_expect = PL_expect;
909 PL_lex_state = LEX_KNOWNEXT;
914 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
916 SV * const sv = newSVpvn(start,len);
917 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
924 * When the lexer knows the next thing is a word (for instance, it has
925 * just seen -> and it knows that the next char is a word char, then
926 * it calls S_force_word to stick the next word into the PL_next lookahead.
929 * char *start : buffer position (must be within PL_linestr)
930 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
931 * int check_keyword : if true, Perl checks to make sure the word isn't
932 * a keyword (do this if the word is a label, e.g. goto FOO)
933 * int allow_pack : if true, : characters will also be allowed (require,
935 * int allow_initial_tick : used by the "sub" lexer only.
939 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
944 start = skipspace(start);
946 if (isIDFIRST_lazy_if(s,UTF) ||
947 (allow_pack && *s == ':') ||
948 (allow_initial_tick && *s == '\'') )
950 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
951 if (check_keyword && keyword(PL_tokenbuf, len))
953 if (token == METHOD) {
958 PL_expect = XOPERATOR;
961 PL_nextval[PL_nexttoke].opval
962 = (OP*)newSVOP(OP_CONST,0,
963 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
964 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
972 * Called when the lexer wants $foo *foo &foo etc, but the program
973 * text only contains the "foo" portion. The first argument is a pointer
974 * to the "foo", and the second argument is the type symbol to prefix.
975 * Forces the next token to be a "WORD".
976 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
980 S_force_ident(pTHX_ register const char *s, int kind)
983 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
984 PL_nextval[PL_nexttoke].opval = o;
987 o->op_private = OPpCONST_ENTERED;
988 /* XXX see note in pp_entereval() for why we forgo typo
989 warnings if the symbol must be introduced in an eval.
991 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
992 kind == '$' ? SVt_PV :
993 kind == '@' ? SVt_PVAV :
994 kind == '%' ? SVt_PVHV :
1002 Perl_str_to_version(pTHX_ SV *sv)
1007 const char *start = SvPV_const(sv,len);
1008 const char * const end = start + len;
1009 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1010 while (start < end) {
1014 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1019 retval += ((NV)n)/nshift;
1028 * Forces the next token to be a version number.
1029 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1030 * and if "guessing" is TRUE, then no new token is created (and the caller
1031 * must use an alternative parsing method).
1035 S_force_version(pTHX_ char *s, int guessing)
1037 OP *version = Nullop;
1046 while (isDIGIT(*d) || *d == '_' || *d == '.')
1048 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1050 s = scan_num(s, &yylval);
1051 version = yylval.opval;
1052 ver = cSVOPx(version)->op_sv;
1053 if (SvPOK(ver) && !SvNIOK(ver)) {
1054 SvUPGRADE(ver, SVt_PVNV);
1055 SvNV_set(ver, str_to_version(ver));
1056 SvNOK_on(ver); /* hint that it is a version */
1063 /* NOTE: The parser sees the package name and the VERSION swapped */
1064 PL_nextval[PL_nexttoke].opval = version;
1072 * Tokenize a quoted string passed in as an SV. It finds the next
1073 * chunk, up to end of string or a backslash. It may make a new
1074 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1079 S_tokeq(pTHX_ SV *sv)
1082 register char *send;
1090 s = SvPV_force(sv, len);
1091 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1094 while (s < send && *s != '\\')
1099 if ( PL_hints & HINT_NEW_STRING ) {
1100 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1106 if (s + 1 < send && (s[1] == '\\'))
1107 s++; /* all that, just for this */
1112 SvCUR_set(sv, d - SvPVX_const(sv));
1114 if ( PL_hints & HINT_NEW_STRING )
1115 return new_constant(NULL, 0, "q", sv, pv, "q");
1120 * Now come three functions related to double-quote context,
1121 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1122 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1123 * interact with PL_lex_state, and create fake ( ... ) argument lists
1124 * to handle functions and concatenation.
1125 * They assume that whoever calls them will be setting up a fake
1126 * join call, because each subthing puts a ',' after it. This lets
1129 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1131 * (I'm not sure whether the spurious commas at the end of lcfirst's
1132 * arguments and join's arguments are created or not).
1137 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1139 * Pattern matching will set PL_lex_op to the pattern-matching op to
1140 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1142 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1144 * Everything else becomes a FUNC.
1146 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1147 * had an OP_CONST or OP_READLINE). This just sets us up for a
1148 * call to S_sublex_push().
1152 S_sublex_start(pTHX)
1154 const register I32 op_type = yylval.ival;
1156 if (op_type == OP_NULL) {
1157 yylval.opval = PL_lex_op;
1161 if (op_type == OP_CONST || op_type == OP_READLINE) {
1162 SV *sv = tokeq(PL_lex_stuff);
1164 if (SvTYPE(sv) == SVt_PVIV) {
1165 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1167 const char *p = SvPV_const(sv, len);
1168 SV * const nsv = newSVpvn(p, len);
1174 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1175 PL_lex_stuff = Nullsv;
1176 /* Allow <FH> // "foo" */
1177 if (op_type == OP_READLINE)
1178 PL_expect = XTERMORDORDOR;
1182 PL_sublex_info.super_state = PL_lex_state;
1183 PL_sublex_info.sub_inwhat = op_type;
1184 PL_sublex_info.sub_op = PL_lex_op;
1185 PL_lex_state = LEX_INTERPPUSH;
1189 yylval.opval = PL_lex_op;
1199 * Create a new scope to save the lexing state. The scope will be
1200 * ended in S_sublex_done. Returns a '(', starting the function arguments
1201 * to the uc, lc, etc. found before.
1202 * Sets PL_lex_state to LEX_INTERPCONCAT.
1211 PL_lex_state = PL_sublex_info.super_state;
1212 SAVEI32(PL_lex_dojoin);
1213 SAVEI32(PL_lex_brackets);
1214 SAVEI32(PL_lex_casemods);
1215 SAVEI32(PL_lex_starts);
1216 SAVEI32(PL_lex_state);
1217 SAVEVPTR(PL_lex_inpat);
1218 SAVEI32(PL_lex_inwhat);
1219 SAVECOPLINE(PL_curcop);
1220 SAVEPPTR(PL_bufptr);
1221 SAVEPPTR(PL_bufend);
1222 SAVEPPTR(PL_oldbufptr);
1223 SAVEPPTR(PL_oldoldbufptr);
1224 SAVEPPTR(PL_last_lop);
1225 SAVEPPTR(PL_last_uni);
1226 SAVEPPTR(PL_linestart);
1227 SAVESPTR(PL_linestr);
1228 SAVEGENERICPV(PL_lex_brackstack);
1229 SAVEGENERICPV(PL_lex_casestack);
1231 PL_linestr = PL_lex_stuff;
1232 PL_lex_stuff = Nullsv;
1234 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1235 = SvPVX(PL_linestr);
1236 PL_bufend += SvCUR(PL_linestr);
1237 PL_last_lop = PL_last_uni = Nullch;
1238 SAVEFREESV(PL_linestr);
1240 PL_lex_dojoin = FALSE;
1241 PL_lex_brackets = 0;
1242 Newx(PL_lex_brackstack, 120, char);
1243 Newx(PL_lex_casestack, 12, char);
1244 PL_lex_casemods = 0;
1245 *PL_lex_casestack = '\0';
1247 PL_lex_state = LEX_INTERPCONCAT;
1248 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1250 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1251 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1252 PL_lex_inpat = PL_sublex_info.sub_op;
1254 PL_lex_inpat = Nullop;
1261 * Restores lexer state after a S_sublex_push.
1268 if (!PL_lex_starts++) {
1269 SV * const sv = newSVpvn("",0);
1270 if (SvUTF8(PL_linestr))
1272 PL_expect = XOPERATOR;
1273 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1277 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1278 PL_lex_state = LEX_INTERPCASEMOD;
1282 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1283 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1284 PL_linestr = PL_lex_repl;
1286 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1287 PL_bufend += SvCUR(PL_linestr);
1288 PL_last_lop = PL_last_uni = Nullch;
1289 SAVEFREESV(PL_linestr);
1290 PL_lex_dojoin = FALSE;
1291 PL_lex_brackets = 0;
1292 PL_lex_casemods = 0;
1293 *PL_lex_casestack = '\0';
1295 if (SvEVALED(PL_lex_repl)) {
1296 PL_lex_state = LEX_INTERPNORMAL;
1298 /* we don't clear PL_lex_repl here, so that we can check later
1299 whether this is an evalled subst; that means we rely on the
1300 logic to ensure sublex_done() is called again only via the
1301 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1304 PL_lex_state = LEX_INTERPCONCAT;
1305 PL_lex_repl = Nullsv;
1311 PL_bufend = SvPVX(PL_linestr);
1312 PL_bufend += SvCUR(PL_linestr);
1313 PL_expect = XOPERATOR;
1314 PL_sublex_info.sub_inwhat = 0;
1322 Extracts a pattern, double-quoted string, or transliteration. This
1325 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1326 processing a pattern (PL_lex_inpat is true), a transliteration
1327 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1329 Returns a pointer to the character scanned up to. Iff this is
1330 advanced from the start pointer supplied (ie if anything was
1331 successfully parsed), will leave an OP for the substring scanned
1332 in yylval. Caller must intuit reason for not parsing further
1333 by looking at the next characters herself.
1337 double-quoted style: \r and \n
1338 regexp special ones: \D \s
1340 backrefs: \1 (deprecated in substitution replacements)
1341 case and quoting: \U \Q \E
1342 stops on @ and $, but not for $ as tail anchor
1344 In transliterations:
1345 characters are VERY literal, except for - not at the start or end
1346 of the string, which indicates a range. scan_const expands the
1347 range to the full set of intermediate characters.
1349 In double-quoted strings:
1351 double-quoted style: \r and \n
1353 backrefs: \1 (deprecated)
1354 case and quoting: \U \Q \E
1357 scan_const does *not* construct ops to handle interpolated strings.
1358 It stops processing as soon as it finds an embedded $ or @ variable
1359 and leaves it to the caller to work out what's going on.
1361 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1363 $ in pattern could be $foo or could be tail anchor. Assumption:
1364 it's a tail anchor if $ is the last thing in the string, or if it's
1365 followed by one of ")| \n\t"
1367 \1 (backreferences) are turned into $1
1369 The structure of the code is
1370 while (there's a character to process) {
1371 handle transliteration ranges
1372 skip regexp comments
1373 skip # initiated comments in //x patterns
1374 check for embedded @foo
1375 check for embedded scalars
1377 leave intact backslashes from leave (below)
1378 deprecate \1 in strings and sub replacements
1379 handle string-changing backslashes \l \U \Q \E, etc.
1380 switch (what was escaped) {
1381 handle - in a transliteration (becomes a literal -)
1382 handle \132 octal characters
1383 handle 0x15 hex characters
1384 handle \cV (control V)
1385 handle printf backslashes (\f, \r, \n, etc)
1387 } (end if backslash)
1388 } (end while character to read)
1393 S_scan_const(pTHX_ char *start)
1395 register char *send = PL_bufend; /* end of the constant */
1396 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1397 register char *s = start; /* start of the constant */
1398 register char *d = SvPVX(sv); /* destination for copies */
1399 bool dorange = FALSE; /* are we in a translit range? */
1400 bool didrange = FALSE; /* did we just finish a range? */
1401 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1402 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1405 UV literal_endpoint = 0;
1408 const char *leaveit = /* set of acceptably-backslashed characters */
1410 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1413 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1414 /* If we are doing a trans and we know we want UTF8 set expectation */
1415 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1416 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1420 while (s < send || dorange) {
1421 /* get transliterations out of the way (they're most literal) */
1422 if (PL_lex_inwhat == OP_TRANS) {
1423 /* expand a range A-Z to the full set of characters. AIE! */
1425 I32 i; /* current expanded character */
1426 I32 min; /* first character in range */
1427 I32 max; /* last character in range */
1430 char * const c = (char*)utf8_hop((U8*)d, -1);
1434 *c = (char)UTF_TO_NATIVE(0xff);
1435 /* mark the range as done, and continue */
1441 i = d - SvPVX_const(sv); /* remember current offset */
1442 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1443 d = SvPVX(sv) + i; /* refresh d after realloc */
1444 d -= 2; /* eat the first char and the - */
1446 min = (U8)*d; /* first char in range */
1447 max = (U8)d[1]; /* last char in range */
1451 "Invalid range \"%c-%c\" in transliteration operator",
1452 (char)min, (char)max);
1456 if (literal_endpoint == 2 &&
1457 ((isLOWER(min) && isLOWER(max)) ||
1458 (isUPPER(min) && isUPPER(max)))) {
1460 for (i = min; i <= max; i++)
1462 *d++ = NATIVE_TO_NEED(has_utf8,i);
1464 for (i = min; i <= max; i++)
1466 *d++ = NATIVE_TO_NEED(has_utf8,i);
1471 for (i = min; i <= max; i++)
1474 /* mark the range as done, and continue */
1478 literal_endpoint = 0;
1483 /* range begins (ignore - as first or last char) */
1484 else if (*s == '-' && s+1 < send && s != start) {
1486 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1489 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1499 literal_endpoint = 0;
1504 /* if we get here, we're not doing a transliteration */
1506 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1507 except for the last char, which will be done separately. */
1508 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1510 while (s+1 < send && *s != ')')
1511 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1513 else if (s[2] == '{' /* This should match regcomp.c */
1514 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1517 char *regparse = s + (s[2] == '{' ? 3 : 4);
1520 while (count && (c = *regparse)) {
1521 if (c == '\\' && regparse[1])
1529 if (*regparse != ')')
1530 regparse--; /* Leave one char for continuation. */
1531 while (s < regparse)
1532 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1536 /* likewise skip #-initiated comments in //x patterns */
1537 else if (*s == '#' && PL_lex_inpat &&
1538 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1539 while (s+1 < send && *s != '\n')
1540 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1543 /* check for embedded arrays
1544 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1546 else if (*s == '@' && s[1]
1547 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1550 /* check for embedded scalars. only stop if we're sure it's a
1553 else if (*s == '$') {
1554 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1556 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1557 break; /* in regexp, $ might be tail anchor */
1560 /* End of else if chain - OP_TRANS rejoin rest */
1563 if (*s == '\\' && s+1 < send) {
1566 /* some backslashes we leave behind */
1567 if (*leaveit && *s && strchr(leaveit, *s)) {
1568 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1569 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1573 /* deprecate \1 in strings and substitution replacements */
1574 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1575 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1577 if (ckWARN(WARN_SYNTAX))
1578 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1583 /* string-change backslash escapes */
1584 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1589 /* if we get here, it's either a quoted -, or a digit */
1592 /* quoted - in transliterations */
1594 if (PL_lex_inwhat == OP_TRANS) {
1604 Perl_warner(aTHX_ packWARN(WARN_MISC),
1605 "Unrecognized escape \\%c passed through",
1607 /* default action is to copy the quoted character */
1608 goto default_action;
1611 /* \132 indicates an octal constant */
1612 case '0': case '1': case '2': case '3':
1613 case '4': case '5': case '6': case '7':
1617 uv = grok_oct(s, &len, &flags, NULL);
1620 goto NUM_ESCAPE_INSERT;
1622 /* \x24 indicates a hex constant */
1626 char* const e = strchr(s, '}');
1627 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1628 PERL_SCAN_DISALLOW_PREFIX;
1633 yyerror("Missing right brace on \\x{}");
1637 uv = grok_hex(s, &len, &flags, NULL);
1643 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1644 uv = grok_hex(s, &len, &flags, NULL);
1650 /* Insert oct or hex escaped character.
1651 * There will always enough room in sv since such
1652 * escapes will be longer than any UTF-8 sequence
1653 * they can end up as. */
1655 /* We need to map to chars to ASCII before doing the tests
1658 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1659 if (!has_utf8 && uv > 255) {
1660 /* Might need to recode whatever we have
1661 * accumulated so far if it contains any
1664 * (Can't we keep track of that and avoid
1665 * this rescan? --jhi)
1669 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1670 if (!NATIVE_IS_INVARIANT(*c)) {
1675 const STRLEN offset = d - SvPVX_const(sv);
1677 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1681 while (src >= (const U8 *)SvPVX_const(sv)) {
1682 if (!NATIVE_IS_INVARIANT(*src)) {
1683 const U8 ch = NATIVE_TO_ASCII(*src);
1684 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1685 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1695 if (has_utf8 || uv > 255) {
1696 d = (char*)uvchr_to_utf8((U8*)d, uv);
1698 if (PL_lex_inwhat == OP_TRANS &&
1699 PL_sublex_info.sub_op) {
1700 PL_sublex_info.sub_op->op_private |=
1701 (PL_lex_repl ? OPpTRANS_FROM_UTF
1714 /* \N{LATIN SMALL LETTER A} is a named character */
1718 char* e = strchr(s, '}');
1724 yyerror("Missing right brace on \\N{}");
1728 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1730 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1731 PERL_SCAN_DISALLOW_PREFIX;
1734 uv = grok_hex(s, &len, &flags, NULL);
1736 goto NUM_ESCAPE_INSERT;
1738 res = newSVpvn(s + 1, e - s - 1);
1739 res = new_constant( Nullch, 0, "charnames",
1740 res, Nullsv, "\\N{...}" );
1742 sv_utf8_upgrade(res);
1743 str = SvPV_const(res,len);
1744 #ifdef EBCDIC_NEVER_MIND
1745 /* charnames uses pack U and that has been
1746 * recently changed to do the below uni->native
1747 * mapping, so this would be redundant (and wrong,
1748 * the code point would be doubly converted).
1749 * But leave this in just in case the pack U change
1750 * gets revoked, but the semantics is still
1751 * desireable for charnames. --jhi */
1753 UV uv = utf8_to_uvchr((const U8*)str, 0);
1756 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
1758 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1759 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1760 str = SvPV_const(res, len);
1764 if (!has_utf8 && SvUTF8(res)) {
1765 const char * const ostart = SvPVX_const(sv);
1766 SvCUR_set(sv, d - ostart);
1769 sv_utf8_upgrade(sv);
1770 /* this just broke our allocation above... */
1771 SvGROW(sv, (STRLEN)(send - start));
1772 d = SvPVX(sv) + SvCUR(sv);
1775 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1776 const char * const odest = SvPVX_const(sv);
1778 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1779 d = SvPVX(sv) + (d - odest);
1781 Copy(str, d, len, char);
1788 yyerror("Missing braces on \\N{}");
1791 /* \c is a control character */
1800 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1803 yyerror("Missing control char name in \\c");
1807 /* printf-style backslashes, formfeeds, newlines, etc */
1809 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1812 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1815 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1818 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1821 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1824 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1827 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1833 } /* end if (backslash) */
1840 /* If we started with encoded form, or already know we want it
1841 and then encode the next character */
1842 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1844 const UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1845 const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1848 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1849 const STRLEN off = d - SvPVX_const(sv);
1850 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1852 d = (char*)uvchr_to_utf8((U8*)d, uv);
1856 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1858 } /* while loop to process each character */
1860 /* terminate the string and set up the sv */
1862 SvCUR_set(sv, d - SvPVX_const(sv));
1863 if (SvCUR(sv) >= SvLEN(sv))
1864 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1867 if (PL_encoding && !has_utf8) {
1868 sv_recode_to_utf8(sv, PL_encoding);
1874 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1875 PL_sublex_info.sub_op->op_private |=
1876 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1880 /* shrink the sv if we allocated more than we used */
1881 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1882 SvPV_shrink_to_cur(sv);
1885 /* return the substring (via yylval) only if we parsed anything */
1886 if (s > PL_bufptr) {
1887 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1888 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1890 ( PL_lex_inwhat == OP_TRANS
1892 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1895 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1902 * Returns TRUE if there's more to the expression (e.g., a subscript),
1905 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1907 * ->[ and ->{ return TRUE
1908 * { and [ outside a pattern are always subscripts, so return TRUE
1909 * if we're outside a pattern and it's not { or [, then return FALSE
1910 * if we're in a pattern and the first char is a {
1911 * {4,5} (any digits around the comma) returns FALSE
1912 * if we're in a pattern and the first char is a [
1914 * [SOMETHING] has a funky algorithm to decide whether it's a
1915 * character class or not. It has to deal with things like
1916 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1917 * anything else returns TRUE
1920 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1923 S_intuit_more(pTHX_ register char *s)
1925 if (PL_lex_brackets)
1927 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1929 if (*s != '{' && *s != '[')
1934 /* In a pattern, so maybe we have {n,m}. */
1951 /* On the other hand, maybe we have a character class */
1954 if (*s == ']' || *s == '^')
1957 /* this is terrifying, and it works */
1958 int weight = 2; /* let's weigh the evidence */
1960 unsigned char un_char = 255, last_un_char;
1961 const char * const send = strchr(s,']');
1962 char tmpbuf[sizeof PL_tokenbuf * 4];
1964 if (!send) /* has to be an expression */
1967 Zero(seen,256,char);
1970 else if (isDIGIT(*s)) {
1972 if (isDIGIT(s[1]) && s[2] == ']')
1978 for (; s < send; s++) {
1979 last_un_char = un_char;
1980 un_char = (unsigned char)*s;
1985 weight -= seen[un_char] * 10;
1986 if (isALNUM_lazy_if(s+1,UTF)) {
1987 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1988 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1993 else if (*s == '$' && s[1] &&
1994 strchr("[#!%*<>()-=",s[1])) {
1995 if (/*{*/ strchr("])} =",s[2]))
2004 if (strchr("wds]",s[1]))
2006 else if (seen['\''] || seen['"'])
2008 else if (strchr("rnftbxcav",s[1]))
2010 else if (isDIGIT(s[1])) {
2012 while (s[1] && isDIGIT(s[1]))
2022 if (strchr("aA01! ",last_un_char))
2024 if (strchr("zZ79~",s[1]))
2026 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2027 weight -= 5; /* cope with negative subscript */
2030 if (!isALNUM(last_un_char)
2031 && !(last_un_char == '$' || last_un_char == '@'
2032 || last_un_char == '&')
2033 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2038 if (keyword(tmpbuf, d - tmpbuf))
2041 if (un_char == last_un_char + 1)
2043 weight -= seen[un_char];
2048 if (weight >= 0) /* probably a character class */
2058 * Does all the checking to disambiguate
2060 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2061 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2063 * First argument is the stuff after the first token, e.g. "bar".
2065 * Not a method if bar is a filehandle.
2066 * Not a method if foo is a subroutine prototyped to take a filehandle.
2067 * Not a method if it's really "Foo $bar"
2068 * Method if it's "foo $bar"
2069 * Not a method if it's really "print foo $bar"
2070 * Method if it's really "foo package::" (interpreted as package->foo)
2071 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2072 * Not a method if bar is a filehandle or package, but is quoted with
2077 S_intuit_method(pTHX_ char *start, GV *gv)
2079 char *s = start + (*start == '$');
2080 char tmpbuf[sizeof PL_tokenbuf];
2088 if ((cv = GvCVu(gv))) {
2089 const char *proto = SvPVX_const(cv);
2099 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2100 /* start is the beginning of the possible filehandle/object,
2101 * and s is the end of it
2102 * tmpbuf is a copy of it
2105 if (*start == '$') {
2106 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2111 return *s == '(' ? FUNCMETH : METHOD;
2113 if (!keyword(tmpbuf, len)) {
2114 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2119 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2120 if (indirgv && GvCVu(indirgv))
2122 /* filehandle or package name makes it a method */
2123 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2125 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2126 return 0; /* no assumptions -- "=>" quotes bearword */
2128 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
2129 newSVpvn(tmpbuf,len));
2130 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
2134 return *s == '(' ? FUNCMETH : METHOD;
2142 * Return a string of Perl code to load the debugger. If PERL5DB
2143 * is set, it will return the contents of that, otherwise a
2144 * compile-time require of perl5db.pl.
2151 const char * const pdb = PerlEnv_getenv("PERL5DB");
2155 SETERRNO(0,SS_NORMAL);
2156 return "BEGIN { require 'perl5db.pl' }";
2162 /* Encoded script support. filter_add() effectively inserts a
2163 * 'pre-processing' function into the current source input stream.
2164 * Note that the filter function only applies to the current source file
2165 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2167 * The datasv parameter (which may be NULL) can be used to pass
2168 * private data to this instance of the filter. The filter function
2169 * can recover the SV using the FILTER_DATA macro and use it to
2170 * store private buffers and state information.
2172 * The supplied datasv parameter is upgraded to a PVIO type
2173 * and the IoDIRP/IoANY field is used to store the function pointer,
2174 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2175 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2176 * private use must be set using malloc'd pointers.
2180 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2185 if (!PL_rsfp_filters)
2186 PL_rsfp_filters = newAV();
2188 datasv = NEWSV(255,0);
2189 SvUPGRADE(datasv, SVt_PVIO);
2190 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2191 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2192 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2193 IoANY(datasv), SvPV_nolen(datasv)));
2194 av_unshift(PL_rsfp_filters, 1);
2195 av_store(PL_rsfp_filters, 0, datasv) ;
2200 /* Delete most recently added instance of this filter function. */
2202 Perl_filter_del(pTHX_ filter_t funcp)
2207 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
2209 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2211 /* if filter is on top of stack (usual case) just pop it off */
2212 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2213 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2214 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2215 IoANY(datasv) = (void *)NULL;
2216 sv_free(av_pop(PL_rsfp_filters));
2220 /* we need to search for the correct entry and clear it */
2221 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2225 /* Invoke the idxth filter function for the current rsfp. */
2226 /* maxlen 0 = read one text line */
2228 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2233 if (!PL_rsfp_filters)
2235 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2236 /* Provide a default input filter to make life easy. */
2237 /* Note that we append to the line. This is handy. */
2238 DEBUG_P(PerlIO_printf(Perl_debug_log,
2239 "filter_read %d: from rsfp\n", idx));
2243 const int old_len = SvCUR(buf_sv);
2245 /* ensure buf_sv is large enough */
2246 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2247 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2248 if (PerlIO_error(PL_rsfp))
2249 return -1; /* error */
2251 return 0 ; /* end of file */
2253 SvCUR_set(buf_sv, old_len + len) ;
2256 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2257 if (PerlIO_error(PL_rsfp))
2258 return -1; /* error */
2260 return 0 ; /* end of file */
2263 return SvCUR(buf_sv);
2265 /* Skip this filter slot if filter has been deleted */
2266 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2267 DEBUG_P(PerlIO_printf(Perl_debug_log,
2268 "filter_read %d: skipped (filter deleted)\n",
2270 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2272 /* Get function pointer hidden within datasv */
2273 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2274 DEBUG_P(PerlIO_printf(Perl_debug_log,
2275 "filter_read %d: via function %p (%s)\n",
2276 idx, datasv, SvPV_nolen_const(datasv)));
2277 /* Call function. The function is expected to */
2278 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2279 /* Return: <0:error, =0:eof, >0:not eof */
2280 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2284 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2286 #ifdef PERL_CR_FILTER
2287 if (!PL_rsfp_filters) {
2288 filter_add(S_cr_textfilter,NULL);
2291 if (PL_rsfp_filters) {
2293 SvCUR_set(sv, 0); /* start with empty line */
2294 if (FILTER_READ(0, sv, 0) > 0)
2295 return ( SvPVX(sv) ) ;
2300 return (sv_gets(sv, fp, append));
2304 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2308 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2312 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2313 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2315 return GvHV(gv); /* Foo:: */
2318 /* use constant CLASS => 'MyClass' */
2319 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2321 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2322 pkgname = SvPV_nolen_const(sv);
2326 return gv_stashpv(pkgname, FALSE);
2330 S_tokenize_use(pTHX_ int is_use, char *s) {
2331 if (PL_expect != XSTATE)
2332 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
2333 is_use ? "use" : "no"));
2335 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
2336 s = force_version(s, TRUE);
2337 if (*s == ';' || (s = skipspace(s), *s == ';')) {
2338 PL_nextval[PL_nexttoke].opval = Nullop;
2341 else if (*s == 'v') {
2342 s = force_word(s,WORD,FALSE,TRUE,FALSE);
2343 s = force_version(s, FALSE);
2347 s = force_word(s,WORD,FALSE,TRUE,FALSE);
2348 s = force_version(s, FALSE);
2350 yylval.ival = is_use;
2354 static const char* const exp_name[] =
2355 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2356 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2363 Works out what to call the token just pulled out of the input
2364 stream. The yacc parser takes care of taking the ops we return and
2365 stitching them into a tree.
2371 if read an identifier
2372 if we're in a my declaration
2373 croak if they tried to say my($foo::bar)
2374 build the ops for a my() declaration
2375 if it's an access to a my() variable
2376 are we in a sort block?
2377 croak if my($a); $a <=> $b
2378 build ops for access to a my() variable
2379 if in a dq string, and they've said @foo and we can't find @foo
2381 build ops for a bareword
2382 if we already built the token before, use it.
2387 #pragma segment Perl_yylex
2392 register char *s = PL_bufptr;
2399 I32 orig_keyword = 0;
2402 PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
2403 lex_state_names[PL_lex_state]);
2405 /* check if there's an identifier for us to look at */
2406 if (PL_pending_ident)
2407 return REPORT(S_pending_ident(aTHX));
2409 /* no identifier pending identification */
2411 switch (PL_lex_state) {
2413 case LEX_NORMAL: /* Some compilers will produce faster */
2414 case LEX_INTERPNORMAL: /* code if we comment these out. */
2418 /* when we've already built the next token, just pull it out of the queue */
2421 yylval = PL_nextval[PL_nexttoke];
2423 PL_lex_state = PL_lex_defer;
2424 PL_expect = PL_lex_expect;
2425 PL_lex_defer = LEX_NORMAL;
2427 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2428 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2429 (IV)PL_nexttype[PL_nexttoke]); });
2431 return REPORT(PL_nexttype[PL_nexttoke]);
2433 /* interpolated case modifiers like \L \U, including \Q and \E.
2434 when we get here, PL_bufptr is at the \
2436 case LEX_INTERPCASEMOD:
2438 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2439 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2441 /* handle \E or end of string */
2442 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2444 if (PL_lex_casemods) {
2445 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
2446 PL_lex_casestack[PL_lex_casemods] = '\0';
2448 if (PL_bufptr != PL_bufend
2449 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2451 PL_lex_state = LEX_INTERPCONCAT;
2455 if (PL_bufptr != PL_bufend)
2457 PL_lex_state = LEX_INTERPCONCAT;
2461 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2462 "### Saw case modifier at '%s'\n", PL_bufptr); });
2464 if (s[1] == '\\' && s[2] == 'E') {
2466 PL_lex_state = LEX_INTERPCONCAT;
2470 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2471 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2472 if ((*s == 'L' || *s == 'U') &&
2473 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2474 PL_lex_casestack[--PL_lex_casemods] = '\0';
2477 if (PL_lex_casemods > 10)
2478 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2479 PL_lex_casestack[PL_lex_casemods++] = *s;
2480 PL_lex_casestack[PL_lex_casemods] = '\0';
2481 PL_lex_state = LEX_INTERPCONCAT;
2482 PL_nextval[PL_nexttoke].ival = 0;
2485 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2487 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2489 PL_nextval[PL_nexttoke].ival = OP_LC;
2491 PL_nextval[PL_nexttoke].ival = OP_UC;
2493 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2495 Perl_croak(aTHX_ "panic: yylex");
2499 if (PL_lex_starts) {
2502 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2503 if (PL_lex_casemods == 1 && PL_lex_inpat)
2512 case LEX_INTERPPUSH:
2513 return REPORT(sublex_push());
2515 case LEX_INTERPSTART:
2516 if (PL_bufptr == PL_bufend)
2517 return REPORT(sublex_done());
2518 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2519 "### Interpolated variable at '%s'\n", PL_bufptr); });
2521 PL_lex_dojoin = (*PL_bufptr == '@');
2522 PL_lex_state = LEX_INTERPNORMAL;
2523 if (PL_lex_dojoin) {
2524 PL_nextval[PL_nexttoke].ival = 0;
2526 force_ident("\"", '$');
2527 PL_nextval[PL_nexttoke].ival = 0;
2529 PL_nextval[PL_nexttoke].ival = 0;
2531 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2534 if (PL_lex_starts++) {
2536 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2537 if (!PL_lex_casemods && PL_lex_inpat)
2544 case LEX_INTERPENDMAYBE:
2545 if (intuit_more(PL_bufptr)) {
2546 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2552 if (PL_lex_dojoin) {
2553 PL_lex_dojoin = FALSE;
2554 PL_lex_state = LEX_INTERPCONCAT;
2557 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2558 && SvEVALED(PL_lex_repl))
2560 if (PL_bufptr != PL_bufend)
2561 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2562 PL_lex_repl = Nullsv;
2565 case LEX_INTERPCONCAT:
2567 if (PL_lex_brackets)
2568 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2570 if (PL_bufptr == PL_bufend)
2571 return REPORT(sublex_done());
2573 if (SvIVX(PL_linestr) == '\'') {
2574 SV *sv = newSVsv(PL_linestr);
2577 else if ( PL_hints & HINT_NEW_RE )
2578 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2579 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2583 s = scan_const(PL_bufptr);
2585 PL_lex_state = LEX_INTERPCASEMOD;
2587 PL_lex_state = LEX_INTERPSTART;
2590 if (s != PL_bufptr) {
2591 PL_nextval[PL_nexttoke] = yylval;
2594 if (PL_lex_starts++) {
2595 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2596 if (!PL_lex_casemods && PL_lex_inpat)
2609 PL_lex_state = LEX_NORMAL;
2610 s = scan_formline(PL_bufptr);
2611 if (!PL_lex_formbrack)
2617 PL_oldoldbufptr = PL_oldbufptr;
2620 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
2621 exp_name[PL_expect], s);
2627 if (isIDFIRST_lazy_if(s,UTF))
2629 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2632 goto fake_eof; /* emulate EOF on ^D or ^Z */
2637 if (PL_lex_brackets) {
2638 if (PL_lex_formbrack)
2639 yyerror("Format not terminated");
2641 yyerror("Missing right curly or square bracket");
2643 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2644 "### Tokener got EOF\n");
2648 if (s++ < PL_bufend)
2649 goto retry; /* ignore stray nulls */
2652 if (!PL_in_eval && !PL_preambled) {
2653 PL_preambled = TRUE;
2654 sv_setpv(PL_linestr,incl_perldb());
2655 if (SvCUR(PL_linestr))
2656 sv_catpvn(PL_linestr,";", 1);
2658 while(AvFILLp(PL_preambleav) >= 0) {
2659 SV *tmpsv = av_shift(PL_preambleav);
2660 sv_catsv(PL_linestr, tmpsv);
2661 sv_catpvn(PL_linestr, ";", 1);
2664 sv_free((SV*)PL_preambleav);
2665 PL_preambleav = NULL;
2667 if (PL_minus_n || PL_minus_p) {
2668 sv_catpv(PL_linestr, "LINE: while (<>) {");
2670 sv_catpv(PL_linestr,"chomp;");
2673 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2674 || *PL_splitstr == '"')
2675 && strchr(PL_splitstr + 1, *PL_splitstr))
2676 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2678 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2679 bytes can be used as quoting characters. :-) */
2680 /* The count here deliberately includes the NUL
2681 that terminates the C string constant. This
2682 embeds the opening NUL into the string. */
2683 const char *splits = PL_splitstr;
2684 sv_catpvn(PL_linestr, "our @F=split(q", 15);
2687 if (*splits == '\\')
2688 sv_catpvn(PL_linestr, splits, 1);
2689 sv_catpvn(PL_linestr, splits, 1);
2690 } while (*splits++);
2691 /* This loop will embed the trailing NUL of
2692 PL_linestr as the last thing it does before
2694 sv_catpvn(PL_linestr, ");", 2);
2698 sv_catpv(PL_linestr,"our @F=split(' ');");
2701 sv_catpvn(PL_linestr, "\n", 1);
2702 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2703 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2704 PL_last_lop = PL_last_uni = Nullch;
2705 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2706 SV * const sv = NEWSV(85,0);
2708 sv_upgrade(sv, SVt_PVMG);
2709 sv_setsv(sv,PL_linestr);
2712 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2717 bof = PL_rsfp ? TRUE : FALSE;
2718 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2721 if (PL_preprocess && !PL_in_eval)
2722 (void)PerlProc_pclose(PL_rsfp);
2723 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2724 PerlIO_clearerr(PL_rsfp);
2726 (void)PerlIO_close(PL_rsfp);
2728 PL_doextract = FALSE;
2730 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2731 sv_setpv(PL_linestr,PL_minus_p
2732 ? ";}continue{print;}" : ";}");
2733 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2734 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2735 PL_last_lop = PL_last_uni = Nullch;
2736 PL_minus_n = PL_minus_p = 0;
2739 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2740 PL_last_lop = PL_last_uni = Nullch;
2741 sv_setpvn(PL_linestr,"",0);
2742 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2744 /* If it looks like the start of a BOM or raw UTF-16,
2745 * check if it in fact is. */
2751 #ifdef PERLIO_IS_STDIO
2752 # ifdef __GNU_LIBRARY__
2753 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2754 # define FTELL_FOR_PIPE_IS_BROKEN
2758 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2759 # define FTELL_FOR_PIPE_IS_BROKEN
2764 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2765 /* This loses the possibility to detect the bof
2766 * situation on perl -P when the libc5 is being used.
2767 * Workaround? Maybe attach some extra state to PL_rsfp?
2770 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2772 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2775 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2776 s = swallow_bom((U8*)s);
2780 /* Incest with pod. */
2781 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2782 sv_setpvn(PL_linestr, "", 0);
2783 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2784 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2785 PL_last_lop = PL_last_uni = Nullch;
2786 PL_doextract = FALSE;
2790 } while (PL_doextract);
2791 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2792 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2793 SV * const sv = NEWSV(85,0);
2795 sv_upgrade(sv, SVt_PVMG);
2796 sv_setsv(sv,PL_linestr);
2799 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2801 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2802 PL_last_lop = PL_last_uni = Nullch;
2803 if (CopLINE(PL_curcop) == 1) {
2804 while (s < PL_bufend && isSPACE(*s))
2806 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2810 if (*s == '#' && *(s+1) == '!')
2812 #ifdef ALTERNATE_SHEBANG
2814 static char const as[] = ALTERNATE_SHEBANG;
2815 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2816 d = s + (sizeof(as) - 1);
2818 #endif /* ALTERNATE_SHEBANG */
2827 while (*d && !isSPACE(*d))
2831 #ifdef ARG_ZERO_IS_SCRIPT
2832 if (ipathend > ipath) {
2834 * HP-UX (at least) sets argv[0] to the script name,
2835 * which makes $^X incorrect. And Digital UNIX and Linux,
2836 * at least, set argv[0] to the basename of the Perl
2837 * interpreter. So, having found "#!", we'll set it right.
2839 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2840 assert(SvPOK(x) || SvGMAGICAL(x));
2841 if (sv_eq(x, CopFILESV(PL_curcop))) {
2842 sv_setpvn(x, ipath, ipathend - ipath);
2848 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
2849 const char * const lstart = SvPV_const(x,llen);
2851 bstart += blen - llen;
2852 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2853 sv_setpvn(x, ipath, ipathend - ipath);
2858 TAINT_NOT; /* $^X is always tainted, but that's OK */
2860 #endif /* ARG_ZERO_IS_SCRIPT */
2865 d = instr(s,"perl -");
2867 d = instr(s,"perl");
2869 /* avoid getting into infinite loops when shebang
2870 * line contains "Perl" rather than "perl" */
2872 for (d = ipathend-4; d >= ipath; --d) {
2873 if ((*d == 'p' || *d == 'P')
2874 && !ibcmp(d, "perl", 4))
2884 #ifdef ALTERNATE_SHEBANG
2886 * If the ALTERNATE_SHEBANG on this system starts with a
2887 * character that can be part of a Perl expression, then if
2888 * we see it but not "perl", we're probably looking at the
2889 * start of Perl code, not a request to hand off to some
2890 * other interpreter. Similarly, if "perl" is there, but
2891 * not in the first 'word' of the line, we assume the line
2892 * contains the start of the Perl program.
2894 if (d && *s != '#') {
2895 const char *c = ipath;
2896 while (*c && !strchr("; \t\r\n\f\v#", *c))
2899 d = Nullch; /* "perl" not in first word; ignore */
2901 *s = '#'; /* Don't try to parse shebang line */
2903 #endif /* ALTERNATE_SHEBANG */
2904 #ifndef MACOS_TRADITIONAL
2909 !instr(s,"indir") &&
2910 instr(PL_origargv[0],"perl"))
2917 while (s < PL_bufend && isSPACE(*s))
2919 if (s < PL_bufend) {
2920 Newxz(newargv,PL_origargc+3,char*);
2922 while (s < PL_bufend && !isSPACE(*s))
2925 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2928 newargv = PL_origargv;
2931 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2933 Perl_croak(aTHX_ "Can't exec %s", ipath);
2937 const U32 oldpdb = PL_perldb;
2938 const bool oldn = PL_minus_n;
2939 const bool oldp = PL_minus_p;
2941 while (*d && !isSPACE(*d)) d++;
2942 while (SPACE_OR_TAB(*d)) d++;
2945 const bool switches_done = PL_doswitches;
2947 if (*d == 'M' || *d == 'm' || *d == 'C') {
2948 const char * const m = d;
2949 while (*d && !isSPACE(*d)) d++;
2950 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2953 d = moreswitches(d);
2955 if (PL_doswitches && !switches_done) {
2956 int argc = PL_origargc;
2957 char **argv = PL_origargv;
2960 } while (argc && argv[0][0] == '-' && argv[0][1]);
2961 init_argv_symbols(argc,argv);
2963 if ((PERLDB_LINE && !oldpdb) ||
2964 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2965 /* if we have already added "LINE: while (<>) {",
2966 we must not do it again */
2968 sv_setpvn(PL_linestr, "", 0);
2969 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2970 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2971 PL_last_lop = PL_last_uni = Nullch;
2972 PL_preambled = FALSE;
2974 (void)gv_fetchfile(PL_origfilename);
2977 if (PL_doswitches && !switches_done) {
2978 int argc = PL_origargc;
2979 char **argv = PL_origargv;
2982 } while (argc && argv[0][0] == '-' && argv[0][1]);
2983 init_argv_symbols(argc,argv);
2989 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2991 PL_lex_state = LEX_FORMLINE;
2996 #ifdef PERL_STRICT_CR
2997 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2999 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3001 case ' ': case '\t': case '\f': case 013:
3002 #ifdef MACOS_TRADITIONAL
3009 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3010 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3011 /* handle eval qq[#line 1 "foo"\n ...] */
3012 CopLINE_dec(PL_curcop);
3016 while (s < d && *s != '\n')
3020 else if (s > d) /* Found by Ilya: feed random input to Perl. */
3021 Perl_croak(aTHX_ "panic: input overflow");
3023 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3025 PL_lex_state = LEX_FORMLINE;
3035 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3042 while (s < PL_bufend && SPACE_OR_TAB(*s))
3045 if (strnEQ(s,"=>",2)) {
3046 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3047 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3048 "### Saw unary minus before =>, forcing word '%s'\n", s);
3050 OPERATOR('-'); /* unary minus */
3052 PL_last_uni = PL_oldbufptr;
3054 case 'r': ftst = OP_FTEREAD; break;
3055 case 'w': ftst = OP_FTEWRITE; break;
3056 case 'x': ftst = OP_FTEEXEC; break;
3057 case 'o': ftst = OP_FTEOWNED; break;
3058 case 'R': ftst = OP_FTRREAD; break;
3059 case 'W': ftst = OP_FTRWRITE; break;
3060 case 'X': ftst = OP_FTREXEC; break;
3061 case 'O': ftst = OP_FTROWNED; break;
3062 case 'e': ftst = OP_FTIS; break;
3063 case 'z': ftst = OP_FTZERO; break;
3064 case 's': ftst = OP_FTSIZE; break;
3065 case 'f': ftst = OP_FTFILE; break;
3066 case 'd': ftst = OP_FTDIR; break;
3067 case 'l': ftst = OP_FTLINK; break;
3068 case 'p': ftst = OP_FTPIPE; break;
3069 case 'S': ftst = OP_FTSOCK; break;
3070 case 'u': ftst = OP_FTSUID; break;
3071 case 'g': ftst = OP_FTSGID; break;
3072 case 'k': ftst = OP_FTSVTX; break;
3073 case 'b': ftst = OP_FTBLK; break;
3074 case 'c': ftst = OP_FTCHR; break;
3075 case 't': ftst = OP_FTTTY; break;
3076 case 'T': ftst = OP_FTTEXT; break;
3077 case 'B': ftst = OP_FTBINARY; break;
3078 case 'M': case 'A': case 'C':
3079 gv_fetchpv("\024",TRUE, SVt_PV);
3081 case 'M': ftst = OP_FTMTIME; break;
3082 case 'A': ftst = OP_FTATIME; break;
3083 case 'C': ftst = OP_FTCTIME; break;
3091 PL_last_lop_op = (OPCODE)ftst;
3092 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3093 "### Saw file test %c\n", (int)ftst);
3098 /* Assume it was a minus followed by a one-letter named
3099 * subroutine call (or a -bareword), then. */
3100 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3101 "### '-%c' looked like a file test but was not\n",
3110 if (PL_expect == XOPERATOR)
3115 else if (*s == '>') {
3118 if (isIDFIRST_lazy_if(s,UTF)) {
3119 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3127 if (PL_expect == XOPERATOR)
3130 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3132 OPERATOR('-'); /* unary minus */
3139 if (PL_expect == XOPERATOR)
3144 if (PL_expect == XOPERATOR)
3147 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3153 if (PL_expect != XOPERATOR) {
3154 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3155 PL_expect = XOPERATOR;
3156 force_ident(PL_tokenbuf, '*');
3169 if (PL_expect == XOPERATOR) {
3173 PL_tokenbuf[0] = '%';
3174 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3175 if (!PL_tokenbuf[1]) {
3178 PL_pending_ident = '%';
3197 switch (PL_expect) {
3200 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3202 PL_bufptr = s; /* update in case we back off */
3208 PL_expect = XTERMBLOCK;
3212 while (isIDFIRST_lazy_if(s,UTF)) {
3213 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3214 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3215 if (tmp < 0) tmp = -tmp;
3231 d = scan_str(d,TRUE,TRUE);
3233 /* MUST advance bufptr here to avoid bogus
3234 "at end of line" context messages from yyerror().
3236 PL_bufptr = s + len;
3237 yyerror("Unterminated attribute parameter in attribute list");
3240 return REPORT(0); /* EOF indicator */
3244 SV *sv = newSVpvn(s, len);
3245 sv_catsv(sv, PL_lex_stuff);
3246 attrs = append_elem(OP_LIST, attrs,
3247 newSVOP(OP_CONST, 0, sv));
3248 SvREFCNT_dec(PL_lex_stuff);
3249 PL_lex_stuff = Nullsv;
3252 if (len == 6 && strnEQ(s, "unique", len)) {
3253 if (PL_in_my == KEY_our)
3255 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3257 ; /* skip to avoid loading attributes.pm */
3260 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3263 /* NOTE: any CV attrs applied here need to be part of
3264 the CVf_BUILTIN_ATTRS define in cv.h! */
3265 else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3266 CvLVALUE_on(PL_compcv);
3267 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3268 CvLOCKED_on(PL_compcv);
3269 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3270 CvMETHOD_on(PL_compcv);
3271 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3272 CvASSERTION_on(PL_compcv);
3273 /* After we've set the flags, it could be argued that
3274 we don't need to do the attributes.pm-based setting
3275 process, and shouldn't bother appending recognized
3276 flags. To experiment with that, uncomment the
3277 following "else". (Note that's already been
3278 uncommented. That keeps the above-applied built-in
3279 attributes from being intercepted (and possibly
3280 rejected) by a package's attribute routines, but is
3281 justified by the performance win for the common case
3282 of applying only built-in attributes.) */
3284 attrs = append_elem(OP_LIST, attrs,
3285 newSVOP(OP_CONST, 0,
3289 if (*s == ':' && s[1] != ':')
3292 break; /* require real whitespace or :'s */
3294 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3295 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3296 const char q = ((*s == '\'') ? '"' : '\'');
3297 /* If here for an expression, and parsed no attrs, back off. */
3298 if (tmp == '=' && !attrs) {
3302 /* MUST advance bufptr here to avoid bogus "at end of line"
3303 context messages from yyerror().
3307 yyerror("Unterminated attribute list");
3309 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3317 PL_nextval[PL_nexttoke].opval = attrs;
3325 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3326 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3343 if (PL_lex_brackets <= 0)
3344 yyerror("Unmatched right square bracket");
3347 if (PL_lex_state == LEX_INTERPNORMAL) {
3348 if (PL_lex_brackets == 0) {
3349 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3350 PL_lex_state = LEX_INTERPEND;
3357 if (PL_lex_brackets > 100) {
3358 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3360 switch (PL_expect) {
3362 if (PL_lex_formbrack) {
3366 if (PL_oldoldbufptr == PL_last_lop)
3367 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3369 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3370 OPERATOR(HASHBRACK);
3372 while (s < PL_bufend && SPACE_OR_TAB(*s))
3375 PL_tokenbuf[0] = '\0';
3376 if (d < PL_bufend && *d == '-') {
3377 PL_tokenbuf[0] = '-';
3379 while (d < PL_bufend && SPACE_OR_TAB(*d))
3382 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3383 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3385 while (d < PL_bufend && SPACE_OR_TAB(*d))
3388 const char minus = (PL_tokenbuf[0] == '-');
3389 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3397 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3402 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3407 if (PL_oldoldbufptr == PL_last_lop)
3408 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3410 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3413 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3415 /* This hack is to get the ${} in the message. */
3417 yyerror("syntax error");
3420 OPERATOR(HASHBRACK);
3422 /* This hack serves to disambiguate a pair of curlies
3423 * as being a block or an anon hash. Normally, expectation
3424 * determines that, but in cases where we're not in a
3425 * position to expect anything in particular (like inside
3426 * eval"") we have to resolve the ambiguity. This code
3427 * covers the case where the first term in the curlies is a
3428 * quoted string. Most other cases need to be explicitly
3429 * disambiguated by prepending a "+" before the opening
3430 * curly in order to force resolution as an anon hash.
3432 * XXX should probably propagate the outer expectation
3433 * into eval"" to rely less on this hack, but that could
3434 * potentially break current behavior of eval"".
3438 if (*s == '\'' || *s == '"' || *s == '`') {
3439 /* common case: get past first string, handling escapes */
3440 for (t++; t < PL_bufend && *t != *s;)
3441 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3445 else if (*s == 'q') {
3448 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3451 /* skip q//-like construct */
3453 char open, close, term;
3456 while (t < PL_bufend && isSPACE(*t))
3458 /* check for q => */
3459 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3460 OPERATOR(HASHBRACK);
3464 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3468 for (t++; t < PL_bufend; t++) {
3469 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3471 else if (*t == open)
3475 for (t++; t < PL_bufend; t++) {
3476 if (*t == '\\' && t+1 < PL_bufend)
3478 else if (*t == close && --brackets <= 0)
3480 else if (*t == open)
3487 /* skip plain q word */
3488 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3491 else if (isALNUM_lazy_if(t,UTF)) {
3493 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3496 while (t < PL_bufend && isSPACE(*t))
3498 /* if comma follows first term, call it an anon hash */
3499 /* XXX it could be a comma expression with loop modifiers */
3500 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3501 || (*t == '=' && t[1] == '>')))
3502 OPERATOR(HASHBRACK);
3503 if (PL_expect == XREF)
3506 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3512 yylval.ival = CopLINE(PL_curcop);
3513 if (isSPACE(*s) || *s == '#')
3514 PL_copline = NOLINE; /* invalidate current command line number */
3519 if (PL_lex_brackets <= 0)
3520 yyerror("Unmatched right curly bracket");
3522 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3523 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3524 PL_lex_formbrack = 0;
3525 if (PL_lex_state == LEX_INTERPNORMAL) {
3526 if (PL_lex_brackets == 0) {
3527 if (PL_expect & XFAKEBRACK) {
3528 PL_expect &= XENUMMASK;
3529 PL_lex_state = LEX_INTERPEND;
3531 return yylex(); /* ignore fake brackets */
3533 if (*s == '-' && s[1] == '>')
3534 PL_lex_state = LEX_INTERPENDMAYBE;
3535 else if (*s != '[' && *s != '{')
3536 PL_lex_state = LEX_INTERPEND;
3539 if (PL_expect & XFAKEBRACK) {
3540 PL_expect &= XENUMMASK;
3542 return yylex(); /* ignore fake brackets */
3552 if (PL_expect == XOPERATOR) {
3553 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
3554 && isIDFIRST_lazy_if(s,UTF))
3556 CopLINE_dec(PL_curcop);
3557 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3558 CopLINE_inc(PL_curcop);
3563 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3565 PL_expect = XOPERATOR;
3566 force_ident(PL_tokenbuf, '&');
3570 yylval.ival = (OPpENTERSUB_AMPER<<8);
3589 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp))
3590 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3592 if (PL_expect == XSTATE && isALPHA(tmp) &&
3593 (s == PL_linestart+1 || s[-2] == '\n') )
3595 if (PL_in_eval && !PL_rsfp) {
3600 if (strnEQ(s,"=cut",4)) {
3614 PL_doextract = TRUE;
3617 if (PL_lex_brackets < PL_lex_formbrack) {
3619 #ifdef PERL_STRICT_CR
3620 for (t = s; SPACE_OR_TAB(*t); t++) ;
3622 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3624 if (*t == '\n' || *t == '#') {
3636 /* was this !=~ where !~ was meant?
3637 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3639 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3640 const char *t = s+1;
3642 while (t < PL_bufend && isSPACE(*t))
3645 if (*t == '/' || *t == '?' ||
3646 ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3647 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3648 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3649 "!=~ should be !~");
3658 if (PL_expect != XOPERATOR) {
3659 if (s[1] != '<' && !strchr(s,'>'))
3662 s = scan_heredoc(s);
3664 s = scan_inputsymbol(s);
3665 TERM(sublex_start());
3670 SHop(OP_LEFT_SHIFT);
3684 SHop(OP_RIGHT_SHIFT);
3693 if (PL_expect == XOPERATOR) {
3694 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3697 return REPORT(','); /* grandfather non-comma-format format */
3701 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3702 PL_tokenbuf[0] = '@';
3703 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3704 sizeof PL_tokenbuf - 1, FALSE);
3705 if (PL_expect == XOPERATOR)
3706 no_op("Array length", s);
3707 if (!PL_tokenbuf[1])
3709 PL_expect = XOPERATOR;
3710 PL_pending_ident = '#';
3714 PL_tokenbuf[0] = '$';
3715 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3716 sizeof PL_tokenbuf - 1, FALSE);
3717 if (PL_expect == XOPERATOR)
3719 if (!PL_tokenbuf[1]) {
3721 yyerror("Final $ should be \\$ or $name");
3725 /* This kludge not intended to be bulletproof. */
3726 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3727 yylval.opval = newSVOP(OP_CONST, 0,
3728 newSViv(PL_compiling.cop_arybase));
3729 yylval.opval->op_private = OPpCONST_ARYBASE;
3735 if (PL_lex_state == LEX_NORMAL)
3738 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3740 PL_tokenbuf[0] = '@';
3741 if (ckWARN(WARN_SYNTAX)) {
3744 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3747 PL_bufptr = skipspace(PL_bufptr);
3748 while (t < PL_bufend && *t != ']')
3750 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3751 "Multidimensional syntax %.*s not supported",
3752 (t - PL_bufptr) + 1, PL_bufptr);
3756 else if (*s == '{') {
3758 PL_tokenbuf[0] = '%';
3759 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
3760 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
3762 char tmpbuf[sizeof PL_tokenbuf];
3763 for (t++; isSPACE(*t); t++) ;
3764 if (isIDFIRST_lazy_if(t,UTF)) {
3766 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3767 for (; isSPACE(*t); t++) ;
3768 if (*t == ';' && get_cv(tmpbuf, FALSE))
3769 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3770 "You need to quote \"%s\"", tmpbuf);
3776 PL_expect = XOPERATOR;
3777 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3778 const bool islop = (PL_last_lop == PL_oldoldbufptr);
3779 if (!islop || PL_last_lop_op == OP_GREPSTART)
3780 PL_expect = XOPERATOR;
3781 else if (strchr("$@\"'`q", *s))
3782 PL_expect = XTERM; /* e.g. print $fh "foo" */
3783 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3784 PL_expect = XTERM; /* e.g. print $fh &sub */
3785 else if (isIDFIRST_lazy_if(s,UTF)) {
3786 char tmpbuf[sizeof PL_tokenbuf];
3787 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3788 if ((tmp = keyword(tmpbuf, len))) {
3789 /* binary operators exclude handle interpretations */
3801 PL_expect = XTERM; /* e.g. print $fh length() */
3806 PL_expect = XTERM; /* e.g. print $fh subr() */
3809 else if (isDIGIT(*s))
3810 PL_expect = XTERM; /* e.g. print $fh 3 */
3811 else if (*s == '.' && isDIGIT(s[1]))
3812 PL_expect = XTERM; /* e.g. print $fh .3 */
3813 else if ((*s == '?' || *s == '-' || *s == '+')
3814 && !isSPACE(s[1]) && s[1] != '=')
3815 PL_expect = XTERM; /* e.g. print $fh -1 */
3816 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3817 PL_expect = XTERM; /* e.g. print $fh /.../
3818 XXX except DORDOR operator */
3819 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3820 PL_expect = XTERM; /* print $fh <<"EOF" */
3822 PL_pending_ident = '$';
3826 if (PL_expect == XOPERATOR)
3828 PL_tokenbuf[0] = '@';
3829 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3830 if (!PL_tokenbuf[1]) {
3833 if (PL_lex_state == LEX_NORMAL)
3835 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3837 PL_tokenbuf[0] = '%';
3839 /* Warn about @ where they meant $. */
3840 if (*s == '[' || *s == '{') {
3841 if (ckWARN(WARN_SYNTAX)) {
3842 const char *t = s + 1;
3843 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3845 if (*t == '}' || *t == ']') {
3847 PL_bufptr = skipspace(PL_bufptr);
3848 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3849 "Scalar value %.*s better written as $%.*s",
3850 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3855 PL_pending_ident = '@';
3858 case '/': /* may be division, defined-or, or pattern */
3859 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3863 case '?': /* may either be conditional or pattern */
3864 if(PL_expect == XOPERATOR) {
3872 /* A // operator. */
3882 /* Disable warning on "study /blah/" */
3883 if (PL_oldoldbufptr == PL_last_uni
3884 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3885 || memNE(PL_last_uni, "study", 5)
3886 || isALNUM_lazy_if(PL_last_uni+5,UTF)
3889 s = scan_pat(s,OP_MATCH);
3890 TERM(sublex_start());
3894 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3895 #ifdef PERL_STRICT_CR
3898 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3900 && (s == PL_linestart || s[-1] == '\n') )
3902 PL_lex_formbrack = 0;
3906 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3912 yylval.ival = OPf_SPECIAL;
3918 if (PL_expect != XOPERATOR)
3923 case '0': case '1': case '2': case '3': case '4':
3924 case '5': case '6': case '7': case '8': case '9':
3925 s = scan_num(s, &yylval);
3926 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3927 "### Saw number in '%s'\n", s);
3929 if (PL_expect == XOPERATOR)
3934 s = scan_str(s,FALSE,FALSE);
3935 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3936 "### Saw string before '%s'\n", s);
3938 if (PL_expect == XOPERATOR) {
3939 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3942 return REPORT(','); /* grandfather non-comma-format format */
3948 missingterm((char*)0);
3949 yylval.ival = OP_CONST;
3950 TERM(sublex_start());
3953 s = scan_str(s,FALSE,FALSE);
3954 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3955 "### Saw string before '%s'\n", s);
3957 if (PL_expect == XOPERATOR) {
3958 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3961 return REPORT(','); /* grandfather non-comma-format format */
3967 missingterm((char*)0);
3968 yylval.ival = OP_CONST;
3969 /* FIXME. I think that this can be const if char *d is replaced by
3970 more localised variables. */
3971 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3972 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3973 yylval.ival = OP_STRINGIFY;
3977 TERM(sublex_start());
3980 s = scan_str(s,FALSE,FALSE);
3981 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3982 "### Saw backtick string before '%s'\n", s);
3984 if (PL_expect == XOPERATOR)
3985 no_op("Backticks",s);
3987 missingterm((char*)0);
3988 yylval.ival = OP_BACKTICK;
3990 TERM(sublex_start());
3994 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
3995 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3997 if (PL_expect == XOPERATOR)
3998 no_op("Backslash",s);
4002 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
4003 char *start = s + 2;
4004 while (isDIGIT(*start) || *start == '_')
4006 if (*start == '.' && isDIGIT(start[1])) {
4007 s = scan_num(s, &yylval);
4010 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
4011 else if (!isALPHA(*start) && (PL_expect == XTERM
4012 || PL_expect == XREF || PL_expect == XSTATE
4013 || PL_expect == XTERMORDORDOR)) {
4014 const char c = *start;
4017 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
4020 s = scan_num(s, &yylval);
4027 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
4067 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4069 /* Some keywords can be followed by any delimiter, including ':' */
4070 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4071 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4072 (PL_tokenbuf[0] == 'q' &&
4073 strchr("qwxr", PL_tokenbuf[1])))));
4075 /* x::* is just a word, unless x is "CORE" */
4076 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4080 while (d < PL_bufend && isSPACE(*d))
4081 d++; /* no comments skipped here, or s### is misparsed */
4083 /* Is this a label? */
4084 if (!tmp && PL_expect == XSTATE
4085 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4087 yylval.pval = savepv(PL_tokenbuf);
4092 /* Check for keywords */
4093 tmp = keyword(PL_tokenbuf, len);
4095 /* Is this a word before a => operator? */
4096 if (*d == '=' && d[1] == '>') {
4099 = (OP*)newSVOP(OP_CONST, 0,
4100 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4101 yylval.opval->op_private = OPpCONST_BARE;
4105 if (tmp < 0) { /* second-class keyword? */
4106 GV *ogv = Nullgv; /* override (winner) */
4107 GV *hgv = Nullgv; /* hidden (loser) */
4108 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4110 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4113 if (GvIMPORTED_CV(gv))
4115 else if (! CvMETHOD(cv))
4119 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4120 (gv = *gvp) != (GV*)&PL_sv_undef &&
4121 GvCVu(gv) && GvIMPORTED_CV(gv))
4128 tmp = 0; /* overridden by import or by GLOBAL */
4131 && -tmp==KEY_lock /* XXX generalizable kludge */
4133 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4135 tmp = 0; /* any sub overrides "weak" keyword */
4140 && PL_expect != XOPERATOR
4141 && PL_expect != XTERMORDORDOR)
4143 /* any sub overrides the "err" keyword, except when really an
4144 * operator is expected */
4147 else { /* no override */
4149 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4150 Perl_warner(aTHX_ packWARN(WARN_MISC),
4151 "dump() better written as CORE::dump()");
4155 if (hgv && tmp != KEY_x && tmp != KEY_CORE
4156 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
4157 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4158 "Ambiguous call resolved as CORE::%s(), %s",
4159 GvENAME(hgv), "qualify as such or use &");
4166 default: /* not a keyword */
4170 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4172 /* Get the rest if it looks like a package qualifier */
4174 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4176 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4179 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4180 *s == '\'' ? "'" : "::");
4185 if (PL_expect == XOPERATOR) {
4186 if (PL_bufptr == PL_linestart) {
4187 CopLINE_dec(PL_curcop);
4188 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4189 CopLINE_inc(PL_curcop);
4192 no_op("Bareword",s);
4195 /* Look for a subroutine with this name in current package,
4196 unless name is "Foo::", in which case Foo is a bearword
4197 (and a package name). */
4200 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4202 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4203 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4204 "Bareword \"%s\" refers to nonexistent package",
4207 PL_tokenbuf[len] = '\0';
4214 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4217 /* if we saw a global override before, get the right name */
4220 sv = newSVpvn("CORE::GLOBAL::",14);
4221 sv_catpv(sv,PL_tokenbuf);
4224 /* If len is 0, newSVpv does strlen(), which is correct.
4225 If len is non-zero, then it will be the true length,
4226 and so the scalar will be created correctly. */
4227 sv = newSVpv(PL_tokenbuf,len);
4230 /* Presume this is going to be a bareword of some sort. */
4233 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4234 yylval.opval->op_private = OPpCONST_BARE;
4235 /* UTF-8 package name? */
4236 if (UTF && !IN_BYTES &&
4237 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
4240 /* And if "Foo::", then that's what it certainly is. */
4245 /* See if it's the indirect object for a list operator. */
4247 if (PL_oldoldbufptr &&
4248 PL_oldoldbufptr < PL_bufptr &&
4249 (PL_oldoldbufptr == PL_last_lop
4250 || PL_oldoldbufptr == PL_last_uni) &&
4251 /* NO SKIPSPACE BEFORE HERE! */
4252 (PL_expect == XREF ||
4253 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4255 bool immediate_paren = *s == '(';
4257 /* (Now we can afford to cross potential line boundary.) */
4260 /* Two barewords in a row may indicate method call. */
4262 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4265 /* If not a declared subroutine, it's an indirect object. */
4266 /* (But it's an indir obj regardless for sort.) */
4268 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4269 ((!gv || !GvCVu(gv)) &&
4270 (PL_last_lop_op != OP_MAPSTART &&
4271 PL_last_lop_op != OP_GREPSTART))))
4273 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4278 PL_expect = XOPERATOR;
4281 /* Is this a word before a => operator? */
4282 if (*s == '=' && s[1] == '>' && !pkgname) {
4284 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4285 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4286 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4290 /* If followed by a paren, it's certainly a subroutine. */
4293 if (gv && GvCVu(gv)) {
4294 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4295 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4300 PL_nextval[PL_nexttoke].opval = yylval.opval;
4301 PL_expect = XOPERATOR;
4307 /* If followed by var or block, call it a method (unless sub) */
4309 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4310 PL_last_lop = PL_oldbufptr;
4311 PL_last_lop_op = OP_METHOD;
4315 /* If followed by a bareword, see if it looks like indir obj. */
4318 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4319 && (tmp = intuit_method(s,gv)))
4322 /* Not a method, so call it a subroutine (if defined) */
4324 if (gv && GvCVu(gv)) {
4326 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4327 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4328 "Ambiguous use of -%s resolved as -&%s()",
4329 PL_tokenbuf, PL_tokenbuf);
4330 /* Check for a constant sub */
4332 if ((sv = cv_const_sv(cv))) {
4334 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4335 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4336 yylval.opval->op_private = 0;
4340 /* Resolve to GV now. */
4341 op_free(yylval.opval);
4342 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4343 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4344 PL_last_lop = PL_oldbufptr;
4345 PL_last_lop_op = OP_ENTERSUB;
4346 /* Is there a prototype? */
4349 const char *proto = SvPV_const((SV*)cv, len);
4352 if (*proto == '$' && proto[1] == '\0')
4354 while (*proto == ';')
4356 if (*proto == '&' && *s == '{') {
4357 sv_setpv(PL_subname, PL_curstash ?
4358 "__ANON__" : "__ANON__::__ANON__");
4362 PL_nextval[PL_nexttoke].opval = yylval.opval;
4368 /* Call it a bare word */
4370 if (PL_hints & HINT_STRICT_SUBS)
4371 yylval.opval->op_private |= OPpCONST_STRICT;
4374 if (lastchar != '-') {
4375 if (ckWARN(WARN_RESERVED)) {
4376 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4377 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4378 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4385 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4386 && ckWARN_d(WARN_AMBIGUOUS)) {
4387 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4388 "Operator or semicolon missing before %c%s",
4389 lastchar, PL_tokenbuf);
4390 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4391 "Ambiguous use of %c resolved as operator %c",
4392 lastchar, lastchar);
4398 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4399 newSVpv(CopFILE(PL_curcop),0));
4403 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4404 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4407 case KEY___PACKAGE__:
4408 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4410 ? newSVhek(HvNAME_HEK(PL_curstash))
4417 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4418 const char *pname = "main";
4419 if (PL_tokenbuf[2] == 'D')
4420 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
4421 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4424 GvIOp(gv) = newIO();
4425 IoIFP(GvIOp(gv)) = PL_rsfp;
4426 #if defined(HAS_FCNTL) && defined(F_SETFD)
4428 const int fd = PerlIO_fileno(PL_rsfp);
4429 fcntl(fd,F_SETFD,fd >= 3);
4432 /* Mark this internal pseudo-handle as clean */
4433 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4435 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4436 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4437 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4439 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4440 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4441 /* if the script was opened in binmode, we need to revert
4442 * it to text mode for compatibility; but only iff it has CRs
4443 * XXX this is a questionable hack at best. */
4444 if (PL_bufend-PL_bufptr > 2
4445 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4448 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4449 loc = PerlIO_tell(PL_rsfp);
4450 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4453 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4455 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4456 #endif /* NETWARE */
4457 #ifdef PERLIO_IS_STDIO /* really? */
4458 # if defined(__BORLANDC__)
4459 /* XXX see note in do_binmode() */
4460 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4464 PerlIO_seek(PL_rsfp, loc, 0);
4468 #ifdef PERLIO_LAYERS
4471 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4472 else if (PL_encoding) {
4479 XPUSHs(PL_encoding);
4481 call_method("name", G_SCALAR);
4485 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4486 Perl_form(aTHX_ ":encoding(%"SVf")",
4504 if (PL_expect == XSTATE) {
4511 if (*s == ':' && s[1] == ':') {
4514 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4515 if (!(tmp = keyword(PL_tokenbuf, len)))
4516 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4530 LOP(OP_ACCEPT,XTERM);
4536 LOP(OP_ATAN2,XTERM);
4542 LOP(OP_BINMODE,XTERM);
4545 LOP(OP_BLESS,XTERM);
4554 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4571 if (!PL_cryptseen) {
4572 PL_cryptseen = TRUE;
4576 LOP(OP_CRYPT,XTERM);
4579 LOP(OP_CHMOD,XTERM);
4582 LOP(OP_CHOWN,XTERM);
4585 LOP(OP_CONNECT,XTERM);
4601 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4605 PL_hints |= HINT_BLOCK_SCOPE;
4615 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4616 LOP(OP_DBMOPEN,XTERM);
4622 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4629 yylval.ival = CopLINE(PL_curcop);
4643 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4644 UNIBRACK(OP_ENTEREVAL);
4662 case KEY_endhostent:
4668 case KEY_endservent:
4671 case KEY_endprotoent:
4682 yylval.ival = CopLINE(PL_curcop);
4684 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4686 if ((PL_bufend - p) >= 3 &&
4687 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4689 else if ((PL_bufend - p) >= 4 &&
4690 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4693 if (isIDFIRST_lazy_if(p,UTF)) {
4694 p = scan_ident(p, PL_bufend,
4695 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4699 Perl_croak(aTHX_ "Missing $ on loop variable");
4704 LOP(OP_FORMLINE,XTERM);
4710 LOP(OP_FCNTL,XTERM);
4716 LOP(OP_FLOCK,XTERM);
4725 LOP(OP_GREPSTART, XREF);
4728 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4743 case KEY_getpriority:
4744 LOP(OP_GETPRIORITY,XTERM);
4746 case KEY_getprotobyname:
4749 case KEY_getprotobynumber:
4750 LOP(OP_GPBYNUMBER,XTERM);
4752 case KEY_getprotoent:
4764 case KEY_getpeername:
4765 UNI(OP_GETPEERNAME);
4767 case KEY_gethostbyname:
4770 case KEY_gethostbyaddr:
4771 LOP(OP_GHBYADDR,XTERM);
4773 case KEY_gethostent:
4776 case KEY_getnetbyname:
4779 case KEY_getnetbyaddr:
4780 LOP(OP_GNBYADDR,XTERM);
4785 case KEY_getservbyname:
4786 LOP(OP_GSBYNAME,XTERM);
4788 case KEY_getservbyport:
4789 LOP(OP_GSBYPORT,XTERM);
4791 case KEY_getservent:
4794 case KEY_getsockname:
4795 UNI(OP_GETSOCKNAME);
4797 case KEY_getsockopt:
4798 LOP(OP_GSOCKOPT,XTERM);
4820 yylval.ival = CopLINE(PL_curcop);
4824 LOP(OP_INDEX,XTERM);
4830 LOP(OP_IOCTL,XTERM);
4842 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4874 LOP(OP_LISTEN,XTERM);
4883 s = scan_pat(s,OP_MATCH);
4884 TERM(sublex_start());
4887 LOP(OP_MAPSTART, XREF);
4890 LOP(OP_MKDIR,XTERM);
4893 LOP(OP_MSGCTL,XTERM);
4896 LOP(OP_MSGGET,XTERM);
4899 LOP(OP_MSGRCV,XTERM);
4902 LOP(OP_MSGSND,XTERM);
4908 if (isIDFIRST_lazy_if(s,UTF)) {
4909 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4910 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4912 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4913 if (!PL_in_my_stash) {
4916 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4924 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4931 s = tokenize_use(0, s);
4935 if (*s == '(' || (s = skipspace(s), *s == '('))
4942 if (isIDFIRST_lazy_if(s,UTF)) {
4944 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4945 for (t=d; *t && isSPACE(*t); t++) ;
4946 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4948 && !(t[0] == '=' && t[1] == '>')
4950 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4951 "Precedence problem: open %.*s should be open(%.*s)",
4952 d - s, s, d - s, s);
4958 yylval.ival = OP_OR;
4968 LOP(OP_OPEN_DIR,XTERM);
4971 checkcomma(s,PL_tokenbuf,"filehandle");
4975 checkcomma(s,PL_tokenbuf,"filehandle");
4994 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4998 LOP(OP_PIPE_OP,XTERM);
5001 s = scan_str(s,FALSE,FALSE);
5003 missingterm((char*)0);
5004 yylval.ival = OP_CONST;
5005 TERM(sublex_start());
5011 s = scan_str(s,FALSE,FALSE);
5013 missingterm((char*)0);
5014 PL_expect = XOPERATOR;
5016 if (SvCUR(PL_lex_stuff)) {
5019 d = SvPV_force(PL_lex_stuff, len);
5022 for (; isSPACE(*d) && len; --len, ++d) ;
5025 if (!warned && ckWARN(WARN_QW)) {
5026 for (; !isSPACE(*d) && len; --len, ++d) {
5028 Perl_warner(aTHX_ packWARN(WARN_QW),
5029 "Possible attempt to separate words with commas");
5032 else if (*d == '#') {
5033 Perl_warner(aTHX_ packWARN(WARN_QW),
5034 "Possible attempt to put comments in qw() list");
5040 for (; !isSPACE(*d) && len; --len, ++d) ;
5042 sv = newSVpvn(b, d-b);
5043 if (DO_UTF8(PL_lex_stuff))
5045 words = append_elem(OP_LIST, words,
5046 newSVOP(OP_CONST, 0, tokeq(sv)));
5050 PL_nextval[PL_nexttoke].opval = words;
5055 SvREFCNT_dec(PL_lex_stuff);
5056 PL_lex_stuff = Nullsv;
5062 s = scan_str(s,FALSE,FALSE);
5064 missingterm((char*)0);
5065 yylval.ival = OP_STRINGIFY;
5066 if (SvIVX(PL_lex_stuff) == '\'')
5067 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
5068 TERM(sublex_start());
5071 s = scan_pat(s,OP_QR);
5072 TERM(sublex_start());
5075 s = scan_str(s,FALSE,FALSE);
5077 missingterm((char*)0);
5078 yylval.ival = OP_BACKTICK;
5080 TERM(sublex_start());
5088 s = force_version(s, FALSE);
5090 else if (*s != 'v' || !isDIGIT(s[1])
5091 || (s = force_version(s, TRUE), *s == 'v'))
5093 *PL_tokenbuf = '\0';
5094 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5095 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5096 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5098 yyerror("<> should be quotes");
5106 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5110 LOP(OP_RENAME,XTERM);
5119 LOP(OP_RINDEX,XTERM);
5129 UNIDOR(OP_READLINE);
5142 LOP(OP_REVERSE,XTERM);
5145 UNIDOR(OP_READLINK);
5153 TERM(sublex_start());
5155 TOKEN(1); /* force error */
5164 LOP(OP_SELECT,XTERM);
5170 LOP(OP_SEMCTL,XTERM);
5173 LOP(OP_SEMGET,XTERM);
5176 LOP(OP_SEMOP,XTERM);
5182 LOP(OP_SETPGRP,XTERM);
5184 case KEY_setpriority:
5185 LOP(OP_SETPRIORITY,XTERM);
5187 case KEY_sethostent:
5193 case KEY_setservent:
5196 case KEY_setprotoent:
5206 LOP(OP_SEEKDIR,XTERM);
5208 case KEY_setsockopt:
5209 LOP(OP_SSOCKOPT,XTERM);
5215 LOP(OP_SHMCTL,XTERM);
5218 LOP(OP_SHMGET,XTERM);
5221 LOP(OP_SHMREAD,XTERM);
5224 LOP(OP_SHMWRITE,XTERM);
5227 LOP(OP_SHUTDOWN,XTERM);
5236 LOP(OP_SOCKET,XTERM);
5238 case KEY_socketpair:
5239 LOP(OP_SOCKPAIR,XTERM);
5242 checkcomma(s,PL_tokenbuf,"subroutine name");
5244 if (*s == ';' || *s == ')') /* probably a close */
5245 Perl_croak(aTHX_ "sort is now a reserved word");
5247 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5251 LOP(OP_SPLIT,XTERM);
5254 LOP(OP_SPRINTF,XTERM);
5257 LOP(OP_SPLICE,XTERM);
5272 LOP(OP_SUBSTR,XTERM);
5278 char tmpbuf[sizeof PL_tokenbuf];
5279 SSize_t tboffset = 0;
5280 expectation attrful;
5281 bool have_name, have_proto, bad_proto;
5282 const int key = tmp;
5286 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5287 (*s == ':' && s[1] == ':'))
5290 attrful = XATTRBLOCK;
5291 /* remember buffer pos'n for later force_word */
5292 tboffset = s - PL_oldbufptr;
5293 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5294 if (strchr(tmpbuf, ':'))
5295 sv_setpv(PL_subname, tmpbuf);
5297 sv_setsv(PL_subname,PL_curstname);
5298 sv_catpvn(PL_subname,"::",2);
5299 sv_catpvn(PL_subname,tmpbuf,len);
5306 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5307 PL_expect = XTERMBLOCK;
5308 attrful = XATTRTERM;
5309 sv_setpvn(PL_subname,"?",1);
5313 if (key == KEY_format) {
5315 PL_lex_formbrack = PL_lex_brackets + 1;
5317 (void) force_word(PL_oldbufptr + tboffset, WORD,
5322 /* Look for a prototype */
5326 s = scan_str(s,FALSE,FALSE);
5328 Perl_croak(aTHX_ "Prototype not terminated");
5329 /* strip spaces and check for bad characters */
5330 d = SvPVX(PL_lex_stuff);
5333 for (p = d; *p; ++p) {
5336 if (!strchr("$@%*;[]&\\", *p))
5341 if (bad_proto && ckWARN(WARN_SYNTAX))
5342 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5343 "Illegal character in prototype for %"SVf" : %s",
5345 SvCUR_set(PL_lex_stuff, tmp);
5353 if (*s == ':' && s[1] != ':')
5354 PL_expect = attrful;
5355 else if (*s != '{' && key == KEY_sub) {
5357 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5359 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5363 PL_nextval[PL_nexttoke].opval =
5364 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5365 PL_lex_stuff = Nullsv;
5369 sv_setpv(PL_subname,
5370 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5373 (void) force_word(PL_oldbufptr + tboffset, WORD,
5382 LOP(OP_SYSTEM,XREF);
5385 LOP(OP_SYMLINK,XTERM);
5388 LOP(OP_SYSCALL,XTERM);
5391 LOP(OP_SYSOPEN,XTERM);
5394 LOP(OP_SYSSEEK,XTERM);
5397 LOP(OP_SYSREAD,XTERM);
5400 LOP(OP_SYSWRITE,XTERM);
5404 TERM(sublex_start());
5425 LOP(OP_TRUNCATE,XTERM);
5437 yylval.ival = CopLINE(PL_curcop);
5441 yylval.ival = CopLINE(PL_curcop);
5445 LOP(OP_UNLINK,XTERM);
5451 LOP(OP_UNPACK,XTERM);
5454 LOP(OP_UTIME,XTERM);
5460 LOP(OP_UNSHIFT,XTERM);
5463 s = tokenize_use(1, s);
5473 yylval.ival = CopLINE(PL_curcop);
5477 PL_hints |= HINT_BLOCK_SCOPE;
5484 LOP(OP_WAITPID,XTERM);
5493 ctl_l[0] = toCTRL('L');
5495 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5498 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5503 if (PL_expect == XOPERATOR)
5509 yylval.ival = OP_XOR;
5514 TERM(sublex_start());
5519 #pragma segment Main
5523 S_pending_ident(pTHX)
5526 register I32 tmp = 0;
5527 /* pit holds the identifier we read and pending_ident is reset */
5528 char pit = PL_pending_ident;
5529 PL_pending_ident = 0;
5531 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5532 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5534 /* if we're in a my(), we can't allow dynamics here.
5535 $foo'bar has already been turned into $foo::bar, so
5536 just check for colons.
5538 if it's a legal name, the OP is a PADANY.
5541 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5542 if (strchr(PL_tokenbuf,':'))
5543 yyerror(Perl_form(aTHX_ "No package name allowed for "
5544 "variable %s in \"our\"",
5546 tmp = allocmy(PL_tokenbuf);
5549 if (strchr(PL_tokenbuf,':'))
5550 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5552 yylval.opval = newOP(OP_PADANY, 0);
5553 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5559 build the ops for accesses to a my() variable.
5561 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5562 then used in a comparison. This catches most, but not
5563 all cases. For instance, it catches
5564 sort { my($a); $a <=> $b }
5566 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5567 (although why you'd do that is anyone's guess).
5570 if (!strchr(PL_tokenbuf,':')) {
5572 tmp = pad_findmy(PL_tokenbuf);
5573 if (tmp != NOT_IN_PAD) {
5574 /* might be an "our" variable" */
5575 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5576 /* build ops for a bareword */
5577 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
5578 HEK * const stashname = HvNAME_HEK(stash);
5579 SV * const sym = newSVhek(stashname);
5580 sv_catpvn(sym, "::", 2);
5581 sv_catpv(sym, PL_tokenbuf+1);
5582 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5583 yylval.opval->op_private = OPpCONST_ENTERED;
5586 ? (GV_ADDMULTI | GV_ADDINEVAL)
5589 ((PL_tokenbuf[0] == '$') ? SVt_PV
5590 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5595 /* if it's a sort block and they're naming $a or $b */
5596 if (PL_last_lop_op == OP_SORT &&
5597 PL_tokenbuf[0] == '$' &&
5598 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5601 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5602 d < PL_bufend && *d != '\n';
5605 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5606 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5612 yylval.opval = newOP(OP_PADANY, 0);
5613 yylval.opval->op_targ = tmp;
5619 Whine if they've said @foo in a doublequoted string,
5620 and @foo isn't a variable we can find in the symbol
5623 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5624 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5625 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5626 && ckWARN(WARN_AMBIGUOUS))
5628 /* Downgraded from fatal to warning 20000522 mjd */
5629 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5630 "Possible unintended interpolation of %s in string",
5635 /* build ops for a bareword */
5636 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5637 yylval.opval->op_private = OPpCONST_ENTERED;
5638 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5639 ((PL_tokenbuf[0] == '$') ? SVt_PV
5640 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5646 * The following code was generated by perl_keyword.pl.
5650 Perl_keyword (pTHX_ const char *name, I32 len)
5654 case 1: /* 5 tokens of length 1 */
5686 case 2: /* 18 tokens of length 2 */
5832 case 3: /* 28 tokens of length 3 */
5836 if (name[1] == 'N' &&
5899 if (name[1] == 'i' &&
5939 if (name[1] == 'o' &&
5948 if (name[1] == 'e' &&
5957 if (name[1] == 'n' &&
5966 if (name[1] == 'o' &&
5975 if (name[1] == 'a' &&
5984 if (name[1] == 'o' &&
6046 if (name[1] == 'e' &&
6078 if (name[1] == 'i' &&
6087 if (name[1] == 's' &&
6096 if (name[1] == 'e' &&
6105 if (name[1] == 'o' &&
6117 case 4: /* 40 tokens of length 4 */
6121 if (name[1] == 'O' &&
6131 if (name[1] == 'N' &&
6141 if (name[1] == 'i' &&
6151 if (name[1] == 'h' &&
6161 if (name[1] == 'u' &&
6174 if (name[2] == 'c' &&
6183 if (name[2] == 's' &&
6192 if (name[2] == 'a' &&
6228 if (name[1] == 'o' &&
6241 if (name[2] == 't' &&
6250 if (name[2] == 'o' &&
6259 if (name[2] == 't' &&
6268 if (name[2] == 'e' &&
6281 if (name[1] == 'o' &&
6294 if (name[2] == 'y' &&
6303 if (name[2] == 'l' &&
6319 if (name[2] == 's' &&
6328 if (name[2] == 'n' &&
6337 if (name[2] == 'c' &&
6350 if (name[1] == 'e' &&
6360 if (name[1] == 'p' &&
6373 if (name[2] == 'c' &&
6382 if (name[2] == 'p' &&
6391 if (name[2] == 's' &&
6407 if (name[2] == 'n' &&
6477 if (name[2] == 'r' &&
6486 if (name[2] == 'r' &&
6495 if (name[2] == 'a' &&
6511 if (name[2] == 'l' &&
6578 case 5: /* 36 tokens of length 5 */
6582 if (name[1] == 'E' &&
6593 if (name[1] == 'H' &&
6607 if (name[2] == 'a' &&
6617 if (name[2] == 'a' &&
6631 if (name[1] == 'l' &&
6648 if (name[3] == 'i' &&
6657 if (name[3] == 'o' &&
6693 if (name[2] == 'o' &&
6703 if (name[2] == 'y' &&
6717 if (name[1] == 'l' &&
6731 if (name[2] == 'n' &&
6741 if (name[2] == 'o' &&
6758 if (name[2] == 'd' &&
6768 if (name[2] == 'c' &&
6785 if (name[2] == 'c' &&
6795 if (name[2] == 't' &&
6809 if (name[1] == 'k' &&
6820 if (name[1] == 'r' &&
6834 if (name[2] == 's' &&
6844 if (name[2] == 'd' &&
6861 if (name[2] == 'm' &&
6871 if (name[2] == 'i' &&
6881 if (name[2] == 'e' &&
6891 if (name[2] == 'l' &&
6901 if (name[2] == 'a' &&
6911 if (name[2] == 'u' &&
6925 if (name[1] == 'i' &&
6939 if (name[2] == 'a' &&
6952 if (name[3] == 'e' &&
6987 if (name[2] == 'i' &&
7004 if (name[2] == 'i' &&
7014 if (name[2] == 'i' &&
7031 case 6: /* 33 tokens of length 6 */
7035 if (name[1] == 'c' &&
7050 if (name[2] == 'l' &&
7061 if (name[2] == 'r' &&
7076 if (name[1] == 'e' &&
7091 if (name[2] == 's' &&
7096 if(ckWARN_d(WARN_SYNTAX))
7097 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7103 if (name[2] == 'i' &&
7121 if (name[2] == 'l' &&
7132 if (name[2] == 'r' &&
7147 if (name[1] == 'm' &&
7162 if (name[2] == 'n' &&
7173 if (name[2] == 's' &&
7188 if (name[1] == 's' &&
7194 if (name[4] == 't' &&
7203 if (name[4] == 'e' &&
7212 if (name[4] == 'c' &&
7221 if (name[4] == 'n' &&
7237 if (name[1] == 'r' &&
7255 if (name[3] == 'a' &&
7265 if (name[3] == 'u' &&
7279 if (name[2] == 'n' &&
7297 if (name[2] == 'a' &&
7311 if (name[3] == 'e' &&
7324 if (name[4] == 't' &&
7333 if (name[4] == 'e' &&
7355 if (name[4] == 't' &&
7364 if (name[4] == 'e' &&
7380 if (name[2] == 'c' &&
7391 if (name[2] == 'l' &&
7402 if (name[2] == 'b' &&
7413 if (name[2] == 's' &&
7436 if (name[4] == 's' &&
7445 if (name[4] == 'n' &&
7458 if (name[3] == 'a' &&
7475 if (name[1] == 'a' &&
7490 case 7: /* 28 tokens of length 7 */
7494 if (name[1] == 'E' &&
7507 if (name[1] == '_' &&
7520 if (name[1] == 'i' &&
7527 return -KEY_binmode;
7533 if (name[1] == 'o' &&
7540 return -KEY_connect;
7549 if (name[2] == 'm' &&
7555 return -KEY_dbmopen;
7561 if (name[2] == 'f' &&
7577 if (name[1] == 'o' &&
7590 if (name[1] == 'e' &&
7597 if (name[5] == 'r' &&
7600 return -KEY_getpgrp;
7606 if (name[5] == 'i' &&
7609 return -KEY_getppid;
7622 if (name[1] == 'c' &&
7629 return -KEY_lcfirst;
7635 if (name[1] == 'p' &&
7642 return -KEY_opendir;
7648 if (name[1] == 'a' &&
7666 if (name[3] == 'd' &&
7671 return -KEY_readdir;
7677 if (name[3] == 'u' &&
7688 if (name[3] == 'e' &&
7693 return -KEY_reverse;
7712 if (name[3] == 'k' &&
7717 return -KEY_seekdir;
7723 if (name[3] == 'p' &&
7728 return -KEY_setpgrp;
7738 if (name[2] == 'm' &&
7744 return -KEY_shmread;
7750 if (name[2] == 'r' &&
7756 return -KEY_sprintf;
7765 if (name[3] == 'l' &&
7770 return -KEY_symlink;
7779 if (name[4] == 'a' &&
7783 return -KEY_syscall;
7789 if (name[4] == 'p' &&
7793 return -KEY_sysopen;
7799 if (name[4] == 'e' &&
7803 return -KEY_sysread;
7809 if (name[4] == 'e' &&
7813 return -KEY_sysseek;
7831 if (name[1] == 'e' &&
7838 return -KEY_telldir;
7847 if (name[2] == 'f' &&
7853 return -KEY_ucfirst;
7859 if (name[2] == 's' &&
7865 return -KEY_unshift;
7875 if (name[1] == 'a' &&
7882 return -KEY_waitpid;
7891 case 8: /* 26 tokens of length 8 */
7895 if (name[1] == 'U' &&
7903 return KEY_AUTOLOAD;
7914 if (name[3] == 'A' &&
7920 return KEY___DATA__;
7926 if (name[3] == 'I' &&
7932 return -KEY___FILE__;
7938 if (name[3] == 'I' &&
7944 return -KEY___LINE__;
7960 if (name[2] == 'o' &&
7967 return -KEY_closedir;
7973 if (name[2] == 'n' &&
7980 return -KEY_continue;
7990 if (name[1] == 'b' &&
7998 return -KEY_dbmclose;
8004 if (name[1] == 'n' &&
8010 if (name[4] == 'r' &&
8015 return -KEY_endgrent;
8021 if (name[4] == 'w' &&
8026 return -KEY_endpwent;
8039 if (name[1] == 'o' &&
8047 return -KEY_formline;
8053 if (name[1] == 'e' &&
8064 if (name[6] == 'n' &&
8067 return -KEY_getgrent;
8073 if (name[6] == 'i' &&
8076 return -KEY_getgrgid;
8082 if (name[6] == 'a' &&
8085 return -KEY_getgrnam;
8098 if (name[4] == 'o' &&
8103 return -KEY_getlogin;
8114 if (name[6] == 'n' &&
8117 return -KEY_getpwent;
8123 if (name[6] == 'a' &&
8126 return -KEY_getpwnam;
8132 if (name[6] == 'i' &&
8135 return -KEY_getpwuid;
8155 if (name[1] == 'e' &&
8162 if (name[5] == 'i' &&
8169 return -KEY_readline;
8174 return -KEY_readlink;
8185 if (name[5] == 'i' &&
8189 return -KEY_readpipe;
8210 if (name[4] == 'r' &&
8215 return -KEY_setgrent;
8221 if (name[4] == 'w' &&
8226 return -KEY_setpwent;
8242 if (name[3] == 'w' &&
8248 return -KEY_shmwrite;
8254 if (name[3] == 't' &&
8260 return -KEY_shutdown;
8270 if (name[2] == 's' &&
8277 return -KEY_syswrite;
8287 if (name[1] == 'r' &&
8295 return -KEY_truncate;
8304 case 9: /* 8 tokens of length 9 */
8308 if (name[1] == 'n' &&
8317 return -KEY_endnetent;
8323 if (name[1] == 'e' &&
8332 return -KEY_getnetent;
8338 if (name[1] == 'o' &&
8347 return -KEY_localtime;
8353 if (name[1] == 'r' &&
8362 return KEY_prototype;
8368 if (name[1] == 'u' &&
8377 return -KEY_quotemeta;
8383 if (name[1] == 'e' &&
8392 return -KEY_rewinddir;
8398 if (name[1] == 'e' &&
8407 return -KEY_setnetent;
8413 if (name[1] == 'a' &&
8422 return -KEY_wantarray;
8431 case 10: /* 9 tokens of length 10 */
8435 if (name[1] == 'n' &&
8441 if (name[4] == 'o' &&
8448 return -KEY_endhostent;
8454 if (name[4] == 'e' &&
8461 return -KEY_endservent;
8474 if (name[1] == 'e' &&
8480 if (name[4] == 'o' &&
8487 return -KEY_gethostent;
8496 if (name[5] == 'r' &&
8502 return -KEY_getservent;
8508 if (name[5] == 'c' &&
8514 return -KEY_getsockopt;
8539 if (name[4] == 'o' &&
8546 return -KEY_sethostent;
8555 if (name[5] == 'r' &&
8561 return -KEY_setservent;
8567 if (name[5] == 'c' &&
8573 return -KEY_setsockopt;
8590 if (name[2] == 'c' &&
8599 return -KEY_socketpair;
8612 case 11: /* 8 tokens of length 11 */
8616 if (name[1] == '_' &&
8627 return -KEY___PACKAGE__;
8633 if (name[1] == 'n' &&
8644 return -KEY_endprotoent;
8650 if (name[1] == 'e' &&
8659 if (name[5] == 'e' &&
8666 return -KEY_getpeername;
8675 if (name[6] == 'o' &&
8681 return -KEY_getpriority;
8687 if (name[6] == 't' &&
8693 return -KEY_getprotoent;
8707 if (name[4] == 'o' &&
8715 return -KEY_getsockname;
8728 if (name[1] == 'e' &&
8736 if (name[6] == 'o' &&
8742 return -KEY_setpriority;
8748 if (name[6] == 't' &&
8754 return -KEY_setprotoent;
8770 case 12: /* 2 tokens of length 12 */
8771 if (name[0] == 'g' &&
8783 if (name[9] == 'd' &&
8786 { /* getnetbyaddr */
8787 return -KEY_getnetbyaddr;
8793 if (name[9] == 'a' &&
8796 { /* getnetbyname */
8797 return -KEY_getnetbyname;
8809 case 13: /* 4 tokens of length 13 */
8810 if (name[0] == 'g' &&
8817 if (name[4] == 'o' &&
8826 if (name[10] == 'd' &&
8829 { /* gethostbyaddr */
8830 return -KEY_gethostbyaddr;
8836 if (name[10] == 'a' &&
8839 { /* gethostbyname */
8840 return -KEY_gethostbyname;
8853 if (name[4] == 'e' &&
8862 if (name[10] == 'a' &&
8865 { /* getservbyname */
8866 return -KEY_getservbyname;
8872 if (name[10] == 'o' &&
8875 { /* getservbyport */
8876 return -KEY_getservbyport;
8895 case 14: /* 1 tokens of length 14 */
8896 if (name[0] == 'g' &&
8910 { /* getprotobyname */
8911 return -KEY_getprotobyname;
8916 case 16: /* 1 tokens of length 16 */
8917 if (name[0] == 'g' &&
8933 { /* getprotobynumber */
8934 return -KEY_getprotobynumber;
8948 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
8952 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8953 if (ckWARN(WARN_SYNTAX)) {
8955 for (w = s+2; *w && level; w++) {
8962 for (; *w && isSPACE(*w); w++) ;
8963 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
8964 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8965 "%s (...) interpreted as function",name);
8968 while (s < PL_bufend && isSPACE(*s))
8972 while (s < PL_bufend && isSPACE(*s))
8974 if (isIDFIRST_lazy_if(s,UTF)) {
8976 while (isALNUM_lazy_if(s,UTF))
8978 while (s < PL_bufend && isSPACE(*s))
8982 *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
8983 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
8987 Perl_croak(aTHX_ "No comma allowed after %s", what);
8992 /* Either returns sv, or mortalizes sv and returns a new SV*.
8993 Best used as sv=new_constant(..., sv, ...).
8994 If s, pv are NULL, calls subroutine with one argument,
8995 and type is used with error messages only. */
8998 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9002 HV * const table = GvHV(PL_hintgv); /* ^H */
9006 const char *why1 = "", *why2 = "", *why3 = "";
9008 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9011 why2 = strEQ(key,"charnames")
9012 ? "(possibly a missing \"use charnames ...\")"
9014 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9015 (type ? type: "undef"), why2);
9017 /* This is convoluted and evil ("goto considered harmful")
9018 * but I do not understand the intricacies of all the different
9019 * failure modes of %^H in here. The goal here is to make
9020 * the most probable error message user-friendly. --jhi */
9025 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9026 (type ? type: "undef"), why1, why2, why3);
9028 yyerror(SvPVX_const(msg));
9032 cvp = hv_fetch(table, key, strlen(key), FALSE);
9033 if (!cvp || !SvOK(*cvp)) {
9036 why3 = "} is not defined";
9039 sv_2mortal(sv); /* Parent created it permanently */
9042 pv = sv_2mortal(newSVpvn(s, len));
9044 typesv = sv_2mortal(newSVpv(type, 0));
9046 typesv = &PL_sv_undef;
9048 PUSHSTACKi(PERLSI_OVERLOAD);
9060 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9064 /* Check the eval first */
9065 if (!PL_in_eval && SvTRUE(ERRSV)) {
9066 sv_catpv(ERRSV, "Propagated");
9067 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9069 res = SvREFCNT_inc(sv);
9073 (void)SvREFCNT_inc(res);
9082 why1 = "Call to &{$^H{";
9084 why3 = "}} did not return a defined value";
9092 /* Returns a NUL terminated string, with the length of the string written to
9096 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9098 register char *d = dest;
9099 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
9102 Perl_croak(aTHX_ ident_too_long);
9103 if (isALNUM(*s)) /* UTF handled below */
9105 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9110 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9114 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9115 char *t = s + UTF8SKIP(s);
9116 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9118 if (d + (t - s) > e)
9119 Perl_croak(aTHX_ ident_too_long);
9120 Copy(s, d, t - s, char);
9133 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9137 char *bracket = Nullch;
9143 e = d + destlen - 3; /* two-character token, ending NUL */
9145 while (isDIGIT(*s)) {
9147 Perl_croak(aTHX_ ident_too_long);
9154 Perl_croak(aTHX_ ident_too_long);
9155 if (isALNUM(*s)) /* UTF handled below */
9157 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9162 else if (*s == ':' && s[1] == ':') {
9166 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9167 char *t = s + UTF8SKIP(s);
9168 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9170 if (d + (t - s) > e)
9171 Perl_croak(aTHX_ ident_too_long);
9172 Copy(s, d, t - s, char);
9183 if (PL_lex_state != LEX_NORMAL)
9184 PL_lex_state = LEX_INTERPENDMAYBE;
9187 if (*s == '$' && s[1] &&
9188 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9201 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9206 if (isSPACE(s[-1])) {
9208 const char ch = *s++;
9209 if (!SPACE_OR_TAB(ch)) {
9215 if (isIDFIRST_lazy_if(d,UTF)) {
9219 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9221 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9224 Copy(s, d, e - s, char);
9229 while ((isALNUM(*s) || *s == ':') && d < e)
9232 Perl_croak(aTHX_ ident_too_long);
9235 while (s < send && SPACE_OR_TAB(*s)) s++;
9236 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9237 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9238 const char *brack = *s == '[' ? "[...]" : "{...}";
9239 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9240 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9241 funny, dest, brack, funny, dest, brack);
9244 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9248 /* Handle extended ${^Foo} variables
9249 * 1999-02-27 mjd-perl-patch@plover.com */
9250 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9254 while (isALNUM(*s) && d < e) {
9258 Perl_croak(aTHX_ ident_too_long);
9263 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9264 PL_lex_state = LEX_INTERPEND;
9269 if (PL_lex_state == LEX_NORMAL) {
9270 if (ckWARN(WARN_AMBIGUOUS) &&
9271 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9273 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9274 "Ambiguous use of %c{%s} resolved to %c%s",
9275 funny, dest, funny, dest);
9280 s = bracket; /* let the parser handle it */
9284 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9285 PL_lex_state = LEX_INTERPEND;
9290 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9295 *pmfl |= PMf_GLOBAL;
9297 *pmfl |= PMf_CONTINUE;
9301 *pmfl |= PMf_MULTILINE;
9303 *pmfl |= PMf_SINGLELINE;
9305 *pmfl |= PMf_EXTENDED;
9309 S_scan_pat(pTHX_ char *start, I32 type)
9312 char *s = scan_str(start,FALSE,FALSE);
9315 char * const delimiter = skipspace(start);
9316 Perl_croak(aTHX_ *delimiter == '?'
9317 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9318 : "Search pattern not terminated" );
9321 pm = (PMOP*)newPMOP(type, 0);
9322 if (PL_multi_open == '?')
9323 pm->op_pmflags |= PMf_ONCE;
9325 while (*s && strchr("iomsx", *s))
9326 pmflag(&pm->op_pmflags,*s++);
9329 while (*s && strchr("iogcmsx", *s))
9330 pmflag(&pm->op_pmflags,*s++);
9332 /* issue a warning if /c is specified,but /g is not */
9333 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9334 && ckWARN(WARN_REGEXP))
9336 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
9339 pm->op_pmpermflags = pm->op_pmflags;
9341 PL_lex_op = (OP*)pm;
9342 yylval.ival = OP_MATCH;
9347 S_scan_subst(pTHX_ char *start)
9355 yylval.ival = OP_NULL;
9357 s = scan_str(start,FALSE,FALSE);
9360 Perl_croak(aTHX_ "Substitution pattern not terminated");
9362 if (s[-1] == PL_multi_open)
9365 first_start = PL_multi_start;
9366 s = scan_str(s,FALSE,FALSE);
9369 SvREFCNT_dec(PL_lex_stuff);
9370 PL_lex_stuff = Nullsv;
9372 Perl_croak(aTHX_ "Substitution replacement not terminated");
9374 PL_multi_start = first_start; /* so whole substitution is taken together */
9376 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9382 else if (strchr("iogcmsx", *s))
9383 pmflag(&pm->op_pmflags,*s++);
9388 /* /c is not meaningful with s/// */
9389 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP))
9391 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
9396 PL_sublex_info.super_bufptr = s;
9397 PL_sublex_info.super_bufend = PL_bufend;
9399 pm->op_pmflags |= PMf_EVAL;
9400 repl = newSVpvn("",0);
9402 sv_catpv(repl, es ? "eval " : "do ");
9403 sv_catpvn(repl, "{ ", 2);
9404 sv_catsv(repl, PL_lex_repl);
9405 sv_catpvn(repl, " };", 2);
9407 SvREFCNT_dec(PL_lex_repl);
9411 pm->op_pmpermflags = pm->op_pmflags;
9412 PL_lex_op = (OP*)pm;
9413 yylval.ival = OP_SUBST;
9418 S_scan_trans(pTHX_ char *start)
9427 yylval.ival = OP_NULL;
9429 s = scan_str(start,FALSE,FALSE);
9431 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9432 if (s[-1] == PL_multi_open)
9435 s = scan_str(s,FALSE,FALSE);
9438 SvREFCNT_dec(PL_lex_stuff);
9439 PL_lex_stuff = Nullsv;
9441 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9444 complement = del = squash = 0;
9448 complement = OPpTRANS_COMPLEMENT;
9451 del = OPpTRANS_DELETE;
9454 squash = OPpTRANS_SQUASH;
9463 Newx(tbl, complement&&!del?258:256, short);
9464 o = newPVOP(OP_TRANS, 0, (char*)tbl);
9465 o->op_private &= ~OPpTRANS_ALL;
9466 o->op_private |= del|squash|complement|
9467 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9468 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9471 yylval.ival = OP_TRANS;
9476 S_scan_heredoc(pTHX_ register char *s)
9479 I32 op_type = OP_SCALAR;
9483 const char newline[] = "\n";
9484 const char *found_newline;
9488 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9492 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9495 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9496 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9499 s = delimcpy(d, e, s, PL_bufend, term, &len);
9509 if (!isALNUM_lazy_if(s,UTF))
9510 deprecate_old("bare << to mean <<\"\"");
9511 for (; isALNUM_lazy_if(s,UTF); s++) {
9516 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9517 Perl_croak(aTHX_ "Delimiter for here document is too long");
9520 len = d - PL_tokenbuf;
9521 #ifndef PERL_STRICT_CR
9522 d = strchr(s, '\r');
9524 char * const olds = s;
9526 while (s < PL_bufend) {
9532 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9541 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9545 if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) {
9546 herewas = newSVpvn(s,PL_bufend-s);
9550 herewas = newSVpvn(s,found_newline-s);
9552 s += SvCUR(herewas);
9554 tmpstr = NEWSV(87,79);
9555 sv_upgrade(tmpstr, SVt_PVIV);
9558 SvIV_set(tmpstr, -1);
9560 else if (term == '`') {
9561 op_type = OP_BACKTICK;
9562 SvIV_set(tmpstr, '\\');
9566 PL_multi_start = CopLINE(PL_curcop);
9567 PL_multi_open = PL_multi_close = '<';
9568 term = *PL_tokenbuf;
9569 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9570 char *bufptr = PL_sublex_info.super_bufptr;
9571 char *bufend = PL_sublex_info.super_bufend;
9572 char * const olds = s - SvCUR(herewas);
9573 s = strchr(bufptr, '\n');
9577 while (s < bufend &&
9578 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9580 CopLINE_inc(PL_curcop);
9583 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9584 missingterm(PL_tokenbuf);
9586 sv_setpvn(herewas,bufptr,d-bufptr+1);
9587 sv_setpvn(tmpstr,d+1,s-d);
9589 sv_catpvn(herewas,s,bufend-s);
9590 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9597 while (s < PL_bufend &&
9598 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9600 CopLINE_inc(PL_curcop);
9602 if (s >= PL_bufend) {
9603 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9604 missingterm(PL_tokenbuf);
9606 sv_setpvn(tmpstr,d+1,s-d);
9608 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9610 sv_catpvn(herewas,s,PL_bufend-s);
9611 sv_setsv(PL_linestr,herewas);
9612 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9613 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9614 PL_last_lop = PL_last_uni = Nullch;
9617 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
9618 while (s >= PL_bufend) { /* multiple line string? */
9620 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9621 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9622 missingterm(PL_tokenbuf);
9624 CopLINE_inc(PL_curcop);
9625 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9626 PL_last_lop = PL_last_uni = Nullch;
9627 #ifndef PERL_STRICT_CR
9628 if (PL_bufend - PL_linestart >= 2) {
9629 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9630 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9632 PL_bufend[-2] = '\n';
9634 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9636 else if (PL_bufend[-1] == '\r')
9637 PL_bufend[-1] = '\n';
9639 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9640 PL_bufend[-1] = '\n';
9642 if (PERLDB_LINE && PL_curstash != PL_debstash) {
9643 SV *sv = NEWSV(88,0);
9645 sv_upgrade(sv, SVt_PVMG);
9646 sv_setsv(sv,PL_linestr);
9649 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9651 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9652 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9653 *(SvPVX(PL_linestr) + off ) = ' ';
9654 sv_catsv(PL_linestr,herewas);
9655 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9656 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9660 sv_catsv(tmpstr,PL_linestr);
9665 PL_multi_end = CopLINE(PL_curcop);
9666 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9667 SvPV_shrink_to_cur(tmpstr);
9669 SvREFCNT_dec(herewas);
9671 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9673 else if (PL_encoding)
9674 sv_recode_to_utf8(tmpstr, PL_encoding);
9676 PL_lex_stuff = tmpstr;
9677 yylval.ival = op_type;
9682 takes: current position in input buffer
9683 returns: new position in input buffer
9684 side-effects: yylval and lex_op are set.
9689 <FH> read from filehandle
9690 <pkg::FH> read from package qualified filehandle
9691 <pkg'FH> read from package qualified filehandle
9692 <$fh> read from filehandle in $fh
9698 S_scan_inputsymbol(pTHX_ char *start)
9700 register char *s = start; /* current position in buffer */
9706 d = PL_tokenbuf; /* start of temp holding space */
9707 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9708 end = strchr(s, '\n');
9711 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9713 /* die if we didn't have space for the contents of the <>,
9714 or if it didn't end, or if we see a newline
9717 if (len >= sizeof PL_tokenbuf)
9718 Perl_croak(aTHX_ "Excessively long <> operator");
9720 Perl_croak(aTHX_ "Unterminated <> operator");
9725 Remember, only scalar variables are interpreted as filehandles by
9726 this code. Anything more complex (e.g., <$fh{$num}>) will be
9727 treated as a glob() call.
9728 This code makes use of the fact that except for the $ at the front,
9729 a scalar variable and a filehandle look the same.
9731 if (*d == '$' && d[1]) d++;
9733 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9734 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9737 /* If we've tried to read what we allow filehandles to look like, and
9738 there's still text left, then it must be a glob() and not a getline.
9739 Use scan_str to pull out the stuff between the <> and treat it
9740 as nothing more than a string.
9743 if (d - PL_tokenbuf != len) {
9744 yylval.ival = OP_GLOB;
9746 s = scan_str(start,FALSE,FALSE);
9748 Perl_croak(aTHX_ "Glob not terminated");
9752 bool readline_overriden = FALSE;
9753 GV *gv_readline = Nullgv;
9755 /* we're in a filehandle read situation */
9758 /* turn <> into <ARGV> */
9760 Copy("ARGV",d,5,char);
9762 /* Check whether readline() is overriden */
9763 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9764 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9766 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9767 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9768 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9769 readline_overriden = TRUE;
9771 /* if <$fh>, create the ops to turn the variable into a
9777 /* try to find it in the pad for this block, otherwise find
9778 add symbol table ops
9780 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9781 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9782 HV *stash = PAD_COMPNAME_OURSTASH(tmp);
9783 HEK *stashname = HvNAME_HEK(stash);
9784 SV *sym = sv_2mortal(newSVhek(stashname));
9785 sv_catpvn(sym, "::", 2);
9791 OP *o = newOP(OP_PADSV, 0);
9793 PL_lex_op = readline_overriden
9794 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9795 append_elem(OP_LIST, o,
9796 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9797 : (OP*)newUNOP(OP_READLINE, 0, o);
9806 ? (GV_ADDMULTI | GV_ADDINEVAL)
9809 PL_lex_op = readline_overriden
9810 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9811 append_elem(OP_LIST,
9812 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9813 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9814 : (OP*)newUNOP(OP_READLINE, 0,
9815 newUNOP(OP_RV2SV, 0,
9816 newGVOP(OP_GV, 0, gv)));
9818 if (!readline_overriden)
9819 PL_lex_op->op_flags |= OPf_SPECIAL;
9820 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9821 yylval.ival = OP_NULL;
9824 /* If it's none of the above, it must be a literal filehandle
9825 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9827 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9828 PL_lex_op = readline_overriden
9829 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9830 append_elem(OP_LIST,
9831 newGVOP(OP_GV, 0, gv),
9832 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9833 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9834 yylval.ival = OP_NULL;
9843 takes: start position in buffer
9844 keep_quoted preserve \ on the embedded delimiter(s)
9845 keep_delims preserve the delimiters around the string
9846 returns: position to continue reading from buffer
9847 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9848 updates the read buffer.
9850 This subroutine pulls a string out of the input. It is called for:
9851 q single quotes q(literal text)
9852 ' single quotes 'literal text'
9853 qq double quotes qq(interpolate $here please)
9854 " double quotes "interpolate $here please"
9855 qx backticks qx(/bin/ls -l)
9856 ` backticks `/bin/ls -l`
9857 qw quote words @EXPORT_OK = qw( func() $spam )
9858 m// regexp match m/this/
9859 s/// regexp substitute s/this/that/
9860 tr/// string transliterate tr/this/that/
9861 y/// string transliterate y/this/that/
9862 ($*@) sub prototypes sub foo ($)
9863 (stuff) sub attr parameters sub foo : attr(stuff)
9864 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9866 In most of these cases (all but <>, patterns and transliterate)
9867 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9868 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9869 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9872 It skips whitespace before the string starts, and treats the first
9873 character as the delimiter. If the delimiter is one of ([{< then
9874 the corresponding "close" character )]}> is used as the closing
9875 delimiter. It allows quoting of delimiters, and if the string has
9876 balanced delimiters ([{<>}]) it allows nesting.
9878 On success, the SV with the resulting string is put into lex_stuff or,
9879 if that is already non-NULL, into lex_repl. The second case occurs only
9880 when parsing the RHS of the special constructs s/// and tr/// (y///).
9881 For convenience, the terminating delimiter character is stuffed into
9886 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9888 SV *sv; /* scalar value: string */
9889 char *tmps; /* temp string, used for delimiter matching */
9890 register char *s = start; /* current position in the buffer */
9891 register char term; /* terminating character */
9892 register char *to; /* current position in the sv's data */
9893 I32 brackets = 1; /* bracket nesting level */
9894 bool has_utf8 = FALSE; /* is there any utf8 content? */
9895 I32 termcode; /* terminating char. code */
9896 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9897 STRLEN termlen; /* length of terminating string */
9898 char *last = NULL; /* last position for nesting bracket */
9900 /* skip space before the delimiter */
9904 /* mark where we are, in case we need to report errors */
9907 /* after skipping whitespace, the next character is the terminator */
9910 termcode = termstr[0] = term;
9914 termcode = utf8_to_uvchr((U8*)s, &termlen);
9915 Copy(s, termstr, termlen, U8);
9916 if (!UTF8_IS_INVARIANT(term))
9920 /* mark where we are */
9921 PL_multi_start = CopLINE(PL_curcop);
9922 PL_multi_open = term;
9924 /* find corresponding closing delimiter */
9925 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9926 termcode = termstr[0] = term = tmps[5];
9928 PL_multi_close = term;
9930 /* create a new SV to hold the contents. 87 is leak category, I'm
9931 assuming. 79 is the SV's initial length. What a random number. */
9933 sv_upgrade(sv, SVt_PVIV);
9934 SvIV_set(sv, termcode);
9935 (void)SvPOK_only(sv); /* validate pointer */
9937 /* move past delimiter and try to read a complete string */
9939 sv_catpvn(sv, s, termlen);
9942 if (PL_encoding && !UTF) {
9946 int offset = s - SvPVX_const(PL_linestr);
9947 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9948 &offset, (char*)termstr, termlen);
9949 const char *ns = SvPVX_const(PL_linestr) + offset;
9950 char *svlast = SvEND(sv) - 1;
9952 for (; s < ns; s++) {
9953 if (*s == '\n' && !PL_rsfp)
9954 CopLINE_inc(PL_curcop);
9957 goto read_more_line;
9959 /* handle quoted delimiters */
9960 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9962 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9964 if ((svlast-1 - t) % 2) {
9968 SvCUR_set(sv, SvCUR(sv) - 1);
9973 if (PL_multi_open == PL_multi_close) {
9981 for (t = w = last; t < svlast; w++, t++) {
9982 /* At here, all closes are "was quoted" one,
9983 so we don't check PL_multi_close. */
9985 if (!keep_quoted && *(t+1) == PL_multi_open)
9990 else if (*t == PL_multi_open)
9998 SvCUR_set(sv, w - SvPVX_const(sv));
10001 if (--brackets <= 0)
10006 if (!keep_delims) {
10007 SvCUR_set(sv, SvCUR(sv) - 1);
10013 /* extend sv if need be */
10014 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10015 /* set 'to' to the next character in the sv's string */
10016 to = SvPVX(sv)+SvCUR(sv);
10018 /* if open delimiter is the close delimiter read unbridle */
10019 if (PL_multi_open == PL_multi_close) {
10020 for (; s < PL_bufend; s++,to++) {
10021 /* embedded newlines increment the current line number */
10022 if (*s == '\n' && !PL_rsfp)
10023 CopLINE_inc(PL_curcop);
10024 /* handle quoted delimiters */
10025 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10026 if (!keep_quoted && s[1] == term)
10028 /* any other quotes are simply copied straight through */
10032 /* terminate when run out of buffer (the for() condition), or
10033 have found the terminator */
10034 else if (*s == term) {
10037 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10040 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10046 /* if the terminator isn't the same as the start character (e.g.,
10047 matched brackets), we have to allow more in the quoting, and
10048 be prepared for nested brackets.
10051 /* read until we run out of string, or we find the terminator */
10052 for (; s < PL_bufend; s++,to++) {
10053 /* embedded newlines increment the line count */
10054 if (*s == '\n' && !PL_rsfp)
10055 CopLINE_inc(PL_curcop);
10056 /* backslashes can escape the open or closing characters */
10057 if (*s == '\\' && s+1 < PL_bufend) {
10058 if (!keep_quoted &&
10059 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10064 /* allow nested opens and closes */
10065 else if (*s == PL_multi_close && --brackets <= 0)
10067 else if (*s == PL_multi_open)
10069 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10074 /* terminate the copied string and update the sv's end-of-string */
10076 SvCUR_set(sv, to - SvPVX_const(sv));
10079 * this next chunk reads more into the buffer if we're not done yet
10083 break; /* handle case where we are done yet :-) */
10085 #ifndef PERL_STRICT_CR
10086 if (to - SvPVX_const(sv) >= 2) {
10087 if ((to[-2] == '\r' && to[-1] == '\n') ||
10088 (to[-2] == '\n' && to[-1] == '\r'))
10092 SvCUR_set(sv, to - SvPVX_const(sv));
10094 else if (to[-1] == '\r')
10097 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10102 /* if we're out of file, or a read fails, bail and reset the current
10103 line marker so we can report where the unterminated string began
10106 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10108 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10111 /* we read a line, so increment our line counter */
10112 CopLINE_inc(PL_curcop);
10114 /* update debugger info */
10115 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10116 SV *sv = NEWSV(88,0);
10118 sv_upgrade(sv, SVt_PVMG);
10119 sv_setsv(sv,PL_linestr);
10120 (void)SvIOK_on(sv);
10122 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10125 /* having changed the buffer, we must update PL_bufend */
10126 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10127 PL_last_lop = PL_last_uni = Nullch;
10130 /* at this point, we have successfully read the delimited string */
10132 if (!PL_encoding || UTF) {
10134 sv_catpvn(sv, s, termlen);
10137 if (has_utf8 || PL_encoding)
10140 PL_multi_end = CopLINE(PL_curcop);
10142 /* if we allocated too much space, give some back */
10143 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10144 SvLEN_set(sv, SvCUR(sv) + 1);
10145 SvPV_renew(sv, SvLEN(sv));
10148 /* decide whether this is the first or second quoted string we've read
10161 takes: pointer to position in buffer
10162 returns: pointer to new position in buffer
10163 side-effects: builds ops for the constant in yylval.op
10165 Read a number in any of the formats that Perl accepts:
10167 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10168 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10171 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10173 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10176 If it reads a number without a decimal point or an exponent, it will
10177 try converting the number to an integer and see if it can do so
10178 without loss of precision.
10182 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10184 register const char *s = start; /* current position in buffer */
10185 register char *d; /* destination in temp buffer */
10186 register char *e; /* end of temp buffer */
10187 NV nv; /* number read, as a double */
10188 SV *sv = Nullsv; /* place to put the converted number */
10189 bool floatit; /* boolean: int or float? */
10190 const char *lastub = 0; /* position of last underbar */
10191 static char const number_too_long[] = "Number too long";
10193 /* We use the first character to decide what type of number this is */
10197 Perl_croak(aTHX_ "panic: scan_num");
10199 /* if it starts with a 0, it could be an octal number, a decimal in
10200 0.13 disguise, or a hexadecimal number, or a binary number. */
10204 u holds the "number so far"
10205 shift the power of 2 of the base
10206 (hex == 4, octal == 3, binary == 1)
10207 overflowed was the number more than we can hold?
10209 Shift is used when we add a digit. It also serves as an "are
10210 we in octal/hex/binary?" indicator to disallow hex characters
10211 when in octal mode.
10216 bool overflowed = FALSE;
10217 bool just_zero = TRUE; /* just plain 0 or binary number? */
10218 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10219 static const char* const bases[5] =
10220 { "", "binary", "", "octal", "hexadecimal" };
10221 static const char* const Bases[5] =
10222 { "", "Binary", "", "Octal", "Hexadecimal" };
10223 static const char* const maxima[5] =
10225 "0b11111111111111111111111111111111",
10229 const char *base, *Base, *max;
10231 /* check for hex */
10236 } else if (s[1] == 'b') {
10241 /* check for a decimal in disguise */
10242 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10244 /* so it must be octal */
10251 if (ckWARN(WARN_SYNTAX))
10252 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10253 "Misplaced _ in number");
10257 base = bases[shift];
10258 Base = Bases[shift];
10259 max = maxima[shift];
10261 /* read the rest of the number */
10263 /* x is used in the overflow test,
10264 b is the digit we're adding on. */
10269 /* if we don't mention it, we're done */
10273 /* _ are ignored -- but warned about if consecutive */
10275 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10276 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10277 "Misplaced _ in number");
10281 /* 8 and 9 are not octal */
10282 case '8': case '9':
10284 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10288 case '2': case '3': case '4':
10289 case '5': case '6': case '7':
10291 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10294 case '0': case '1':
10295 b = *s++ & 15; /* ASCII digit -> value of digit */
10299 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10300 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10301 /* make sure they said 0x */
10304 b = (*s++ & 7) + 9;
10306 /* Prepare to put the digit we have onto the end
10307 of the number so far. We check for overflows.
10313 x = u << shift; /* make room for the digit */
10315 if ((x >> shift) != u
10316 && !(PL_hints & HINT_NEW_BINARY)) {
10319 if (ckWARN_d(WARN_OVERFLOW))
10320 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10321 "Integer overflow in %s number",
10324 u = x | b; /* add the digit to the end */
10327 n *= nvshift[shift];
10328 /* If an NV has not enough bits in its
10329 * mantissa to represent an UV this summing of
10330 * small low-order numbers is a waste of time
10331 * (because the NV cannot preserve the
10332 * low-order bits anyway): we could just
10333 * remember when did we overflow and in the
10334 * end just multiply n by the right
10342 /* if we get here, we had success: make a scalar value from
10347 /* final misplaced underbar check */
10348 if (s[-1] == '_') {
10349 if (ckWARN(WARN_SYNTAX))
10350 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10355 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10356 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10357 "%s number > %s non-portable",
10363 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10364 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10365 "%s number > %s non-portable",
10370 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10371 sv = new_constant(start, s - start, "integer",
10373 else if (PL_hints & HINT_NEW_BINARY)
10374 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10379 handle decimal numbers.
10380 we're also sent here when we read a 0 as the first digit
10382 case '1': case '2': case '3': case '4': case '5':
10383 case '6': case '7': case '8': case '9': case '.':
10386 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10389 /* read next group of digits and _ and copy into d */
10390 while (isDIGIT(*s) || *s == '_') {
10391 /* skip underscores, checking for misplaced ones
10395 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10396 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10397 "Misplaced _ in number");
10401 /* check for end of fixed-length buffer */
10403 Perl_croak(aTHX_ number_too_long);
10404 /* if we're ok, copy the character */
10409 /* final misplaced underbar check */
10410 if (lastub && s == lastub + 1) {
10411 if (ckWARN(WARN_SYNTAX))
10412 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10415 /* read a decimal portion if there is one. avoid
10416 3..5 being interpreted as the number 3. followed
10419 if (*s == '.' && s[1] != '.') {
10424 if (ckWARN(WARN_SYNTAX))
10425 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10426 "Misplaced _ in number");
10430 /* copy, ignoring underbars, until we run out of digits.
10432 for (; isDIGIT(*s) || *s == '_'; s++) {
10433 /* fixed length buffer check */
10435 Perl_croak(aTHX_ number_too_long);
10437 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10438 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10439 "Misplaced _ in number");
10445 /* fractional part ending in underbar? */
10446 if (s[-1] == '_') {
10447 if (ckWARN(WARN_SYNTAX))
10448 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10449 "Misplaced _ in number");
10451 if (*s == '.' && isDIGIT(s[1])) {
10452 /* oops, it's really a v-string, but without the "v" */
10458 /* read exponent part, if present */
10459 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10463 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10464 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10466 /* stray preinitial _ */
10468 if (ckWARN(WARN_SYNTAX))
10469 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10470 "Misplaced _ in number");
10474 /* allow positive or negative exponent */
10475 if (*s == '+' || *s == '-')
10478 /* stray initial _ */
10480 if (ckWARN(WARN_SYNTAX))
10481 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10482 "Misplaced _ in number");
10486 /* read digits of exponent */
10487 while (isDIGIT(*s) || *s == '_') {
10490 Perl_croak(aTHX_ number_too_long);
10494 if (((lastub && s == lastub + 1) ||
10495 (!isDIGIT(s[1]) && s[1] != '_'))
10496 && ckWARN(WARN_SYNTAX))
10497 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10498 "Misplaced _ in number");
10505 /* make an sv from the string */
10509 We try to do an integer conversion first if no characters
10510 indicating "float" have been found.
10515 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10517 if (flags == IS_NUMBER_IN_UV) {
10519 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10522 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10523 if (uv <= (UV) IV_MIN)
10524 sv_setiv(sv, -(IV)uv);
10531 /* terminate the string */
10533 nv = Atof(PL_tokenbuf);
10537 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10538 (PL_hints & HINT_NEW_INTEGER) )
10539 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10540 (floatit ? "float" : "integer"),
10544 /* if it starts with a v, it could be a v-string */
10547 sv = NEWSV(92,5); /* preallocate storage space */
10548 s = scan_vstring(s,sv);
10552 /* make the op for the constant and return */
10555 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10557 lvalp->opval = Nullop;
10563 S_scan_formline(pTHX_ register char *s)
10565 register char *eol;
10567 SV *stuff = newSVpvn("",0);
10568 bool needargs = FALSE;
10569 bool eofmt = FALSE;
10571 while (!needargs) {
10573 #ifdef PERL_STRICT_CR
10574 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10576 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10578 if (*t == '\n' || t == PL_bufend) {
10583 if (PL_in_eval && !PL_rsfp) {
10584 eol = (char *) memchr(s,'\n',PL_bufend-s);
10589 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10591 for (t = s; t < eol; t++) {
10592 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10594 goto enough; /* ~~ must be first line in formline */
10596 if (*t == '@' || *t == '^')
10600 sv_catpvn(stuff, s, eol-s);
10601 #ifndef PERL_STRICT_CR
10602 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10603 char *end = SvPVX(stuff) + SvCUR(stuff);
10606 SvCUR_set(stuff, SvCUR(stuff) - 1);
10615 s = filter_gets(PL_linestr, PL_rsfp, 0);
10616 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10617 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10618 PL_last_lop = PL_last_uni = Nullch;
10627 if (SvCUR(stuff)) {
10630 PL_lex_state = LEX_NORMAL;
10631 PL_nextval[PL_nexttoke].ival = 0;
10635 PL_lex_state = LEX_FORMLINE;
10637 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10639 else if (PL_encoding)
10640 sv_recode_to_utf8(stuff, PL_encoding);
10642 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10644 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10648 SvREFCNT_dec(stuff);
10650 PL_lex_formbrack = 0;
10661 PL_cshlen = strlen(PL_cshname);
10666 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10668 const I32 oldsavestack_ix = PL_savestack_ix;
10669 CV* outsidecv = PL_compcv;
10672 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10674 SAVEI32(PL_subline);
10675 save_item(PL_subname);
10676 SAVESPTR(PL_compcv);
10678 PL_compcv = (CV*)NEWSV(1104,0);
10679 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10680 CvFLAGS(PL_compcv) |= flags;
10682 PL_subline = CopLINE(PL_curcop);
10683 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10684 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10685 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10687 return oldsavestack_ix;
10691 #pragma segment Perl_yylex
10694 Perl_yywarn(pTHX_ const char *s)
10696 PL_in_eval |= EVAL_WARNONLY;
10698 PL_in_eval &= ~EVAL_WARNONLY;
10703 Perl_yyerror(pTHX_ const char *s)
10705 const char *where = NULL;
10706 const char *context = NULL;
10710 if (!yychar || (yychar == ';' && !PL_rsfp))
10712 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10713 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10714 PL_oldbufptr != PL_bufptr) {
10717 The code below is removed for NetWare because it abends/crashes on NetWare
10718 when the script has error such as not having the closing quotes like:
10719 if ($var eq "value)
10720 Checking of white spaces is anyway done in NetWare code.
10723 while (isSPACE(*PL_oldoldbufptr))
10726 context = PL_oldoldbufptr;
10727 contlen = PL_bufptr - PL_oldoldbufptr;
10729 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10730 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10733 The code below is removed for NetWare because it abends/crashes on NetWare
10734 when the script has error such as not having the closing quotes like:
10735 if ($var eq "value)
10736 Checking of white spaces is anyway done in NetWare code.
10739 while (isSPACE(*PL_oldbufptr))
10742 context = PL_oldbufptr;
10743 contlen = PL_bufptr - PL_oldbufptr;
10745 else if (yychar > 255)
10746 where = "next token ???";
10747 else if (yychar == -2) { /* YYEMPTY */
10748 if (PL_lex_state == LEX_NORMAL ||
10749 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10750 where = "at end of line";
10751 else if (PL_lex_inpat)
10752 where = "within pattern";
10754 where = "within string";
10757 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10759 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10760 else if (isPRINT_LC(yychar))
10761 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10763 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10764 where = SvPVX_const(where_sv);
10766 msg = sv_2mortal(newSVpv(s, 0));
10767 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10768 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10770 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10772 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10773 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10774 Perl_sv_catpvf(aTHX_ msg,
10775 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10776 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10779 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10780 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10783 if (PL_error_count >= 10) {
10784 if (PL_in_eval && SvCUR(ERRSV))
10785 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10786 ERRSV, OutCopFILE(PL_curcop));
10788 Perl_croak(aTHX_ "%s has too many errors.\n",
10789 OutCopFILE(PL_curcop));
10792 PL_in_my_stash = Nullhv;
10796 #pragma segment Main
10800 S_swallow_bom(pTHX_ U8 *s)
10802 const STRLEN slen = SvCUR(PL_linestr);
10805 if (s[1] == 0xFE) {
10806 /* UTF-16 little-endian? (or UTF32-LE?) */
10807 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10808 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10809 #ifndef PERL_NO_UTF16_FILTER
10810 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10813 if (PL_bufend > (char*)s) {
10817 filter_add(utf16rev_textfilter, NULL);
10818 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10819 utf16_to_utf8_reversed(s, news,
10820 PL_bufend - (char*)s - 1,
10822 sv_setpvn(PL_linestr, (const char*)news, newlen);
10824 SvUTF8_on(PL_linestr);
10825 s = (U8*)SvPVX(PL_linestr);
10826 PL_bufend = SvPVX(PL_linestr) + newlen;
10829 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10834 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10835 #ifndef PERL_NO_UTF16_FILTER
10836 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10839 if (PL_bufend > (char *)s) {
10843 filter_add(utf16_textfilter, NULL);
10844 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10845 utf16_to_utf8(s, news,
10846 PL_bufend - (char*)s,
10848 sv_setpvn(PL_linestr, (const char*)news, newlen);
10850 SvUTF8_on(PL_linestr);
10851 s = (U8*)SvPVX(PL_linestr);
10852 PL_bufend = SvPVX(PL_linestr) + newlen;
10855 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
10860 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10861 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10862 s += 3; /* UTF-8 */
10868 if (s[2] == 0xFE && s[3] == 0xFF) {
10869 /* UTF-32 big-endian */
10870 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
10873 else if (s[2] == 0 && s[3] != 0) {
10876 * are a good indicator of UTF-16BE. */
10877 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10882 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10885 * are a good indicator of UTF-16LE. */
10886 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10895 * Restore a source filter.
10899 restore_rsfp(pTHX_ void *f)
10901 PerlIO *fp = (PerlIO*)f;
10903 if (PL_rsfp == PerlIO_stdin())
10904 PerlIO_clearerr(PL_rsfp);
10905 else if (PL_rsfp && (PL_rsfp != fp))
10906 PerlIO_close(PL_rsfp);
10910 #ifndef PERL_NO_UTF16_FILTER
10912 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10914 const STRLEN old = SvCUR(sv);
10915 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10916 DEBUG_P(PerlIO_printf(Perl_debug_log,
10917 "utf16_textfilter(%p): %d %d (%d)\n",
10918 utf16_textfilter, idx, maxlen, (int) count));
10922 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10923 Copy(SvPVX_const(sv), tmps, old, char);
10924 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10925 SvCUR(sv) - old, &newlen);
10926 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10928 DEBUG_P({sv_dump(sv);});
10933 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10935 const STRLEN old = SvCUR(sv);
10936 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10937 DEBUG_P(PerlIO_printf(Perl_debug_log,
10938 "utf16rev_textfilter(%p): %d %d (%d)\n",
10939 utf16rev_textfilter, idx, maxlen, (int) count));
10943 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10944 Copy(SvPVX_const(sv), tmps, old, char);
10945 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10946 SvCUR(sv) - old, &newlen);
10947 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10949 DEBUG_P({ sv_dump(sv); });
10955 Returns a pointer to the next character after the parsed
10956 vstring, as well as updating the passed in sv.
10958 Function must be called like
10961 s = scan_vstring(s,sv);
10963 The sv should already be large enough to store the vstring
10964 passed in, for performance reasons.
10969 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
10971 const char *pos = s;
10972 const char *start = s;
10973 if (*pos == 'v') pos++; /* get past 'v' */
10974 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
10976 if ( *pos != '.') {
10977 /* this may not be a v-string if followed by => */
10978 const char *next = pos;
10979 while (next < PL_bufend && isSPACE(*next))
10981 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
10982 /* return string not v-string */
10983 sv_setpvn(sv,(char *)s,pos-s);
10984 return (char *)pos;
10988 if (!isALPHA(*pos)) {
10990 U8 tmpbuf[UTF8_MAXBYTES+1];
10993 if (*s == 'v') s++; /* get past 'v' */
10995 sv_setpvn(sv, "", 0);
11000 /* this is atoi() that tolerates underscores */
11001 const char *end = pos;
11003 while (--end >= s) {
11008 rev += (*end - '0') * mult;
11010 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11011 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11012 "Integer overflow in decimal number");
11016 if (rev > 0x7FFFFFFF)
11017 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11019 /* Append native character for the rev point */
11020 tmpend = uvchr_to_utf8(tmpbuf, rev);
11021 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11022 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11024 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11030 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11034 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11042 * c-indentation-style: bsd
11043 * c-basic-offset: 4
11044 * indent-tabs-mode: t
11047 * ex: set ts=8 sts=4 sw=4 noet: