3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 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_yychar
27 #define yylval PL_yylval
29 static char ident_too_long[] = "Identifier too long";
30 static char c_without_g[] = "Use of /c modifier is meaningless without /g";
31 static char c_in_subst[] = "Use of /c modifier is meaningless in s///";
33 static void restore_rsfp(pTHX_ void *f);
34 #ifndef PERL_NO_UTF16_FILTER
35 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
36 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
39 #define XFAKEBRACK 128
42 #ifdef USE_UTF8_SCRIPTS
43 # define UTF (!IN_BYTES)
45 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
48 /* In variables named $^X, these are the legal values for X.
49 * 1999-02-27 mjd-perl-patch@plover.com */
50 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
52 /* On MacOS, respect nonbreaking spaces */
53 #ifdef MACOS_TRADITIONAL
54 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
56 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
59 /* LEX_* are values for PL_lex_state, the state of the lexer.
60 * They are arranged oddly so that the guard on the switch statement
61 * can get by with a single comparison (if the compiler is smart enough).
64 /* #define LEX_NOTPARSING 11 is done in perl.h. */
67 #define LEX_INTERPNORMAL 9
68 #define LEX_INTERPCASEMOD 8
69 #define LEX_INTERPPUSH 7
70 #define LEX_INTERPSTART 6
71 #define LEX_INTERPEND 5
72 #define LEX_INTERPENDMAYBE 4
73 #define LEX_INTERPCONCAT 3
74 #define LEX_INTERPCONST 2
75 #define LEX_FORMLINE 1
76 #define LEX_KNOWNEXT 0
84 # define YYMAXLEVEL 100
86 YYSTYPE* yylval_pointer[YYMAXLEVEL];
87 int* yychar_pointer[YYMAXLEVEL];
91 # define yylval (*yylval_pointer[yyactlevel])
92 # define yychar (*yychar_pointer[yyactlevel])
93 # define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
95 # define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
100 /* CLINE is a macro that ensures PL_copline has a sane value */
105 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
108 * Convenience functions to return different tokens and prime the
109 * lexer for the next token. They all take an argument.
111 * TOKEN : generic token (used for '(', DOLSHARP, etc)
112 * OPERATOR : generic operator
113 * AOPERATOR : assignment operator
114 * PREBLOCK : beginning the block after an if, while, foreach, ...
115 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
116 * PREREF : *EXPR where EXPR is not a simple identifier
117 * TERM : expression term
118 * LOOPX : loop exiting command (goto, last, dump, etc)
119 * FTST : file test operator
120 * FUN0 : zero-argument function
121 * FUN1 : not used, except for not, which isn't a UNIOP
122 * BOop : bitwise or or xor
124 * SHop : shift operator
125 * PWop : power operator
126 * PMop : pattern-matching operator
127 * Aop : addition-level operator
128 * Mop : multiplication-level operator
129 * Eop : equality-testing operator
130 * Rop : relational operator <= != gt
132 * Also see LOP and lop() below.
135 /* Note that REPORT() and REPORT2() will be expressions that supply
136 * their own trailing comma, not suitable for statements as such. */
137 #ifdef DEBUGGING /* Serve -DT. */
138 # define REPORT(x,retval) tokereport(x,s,(int)retval),
139 # define REPORT2(x,retval) tokereport(x,s, yylval.ival),
141 # define REPORT(x,retval)
142 # define REPORT2(x,retval)
145 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
146 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
147 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
148 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
149 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
150 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
151 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
152 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
153 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERMORDORDOR,PL_bufptr = s,(int)UNIOP)
154 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
155 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
156 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
157 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
158 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
159 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
160 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
161 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
162 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
163 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
164 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
166 /* This bit of chicanery makes a unary function followed by
167 * a parenthesis into a function with one argument, highest precedence.
168 * The UNIDOR macro is for unary functions that can be followed by the //
169 * operator (such as C<shift // 0>).
171 #define UNI2(f,x) return(yylval.ival = f, \
175 PL_last_uni = PL_oldbufptr, \
176 PL_last_lop_op = f, \
177 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
178 #define UNI(f) UNI2(f,XTERM)
179 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
181 #define UNIBRACK(f) return(yylval.ival = f, \
184 PL_last_uni = PL_oldbufptr, \
185 (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
187 /* grandfather return to old style */
188 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
193 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
196 SV* report = newSVpv(thing, 0);
197 Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
200 if (s - PL_bufptr > 0)
201 sv_catpvn(report, PL_bufptr, s - PL_bufptr);
203 if (PL_oldbufptr && *PL_oldbufptr)
204 sv_catpv(report, PL_tokenbuf);
206 PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
215 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
216 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
220 S_ao(pTHX_ int toketype)
222 if (*PL_bufptr == '=') {
224 if (toketype == ANDAND)
225 yylval.ival = OP_ANDASSIGN;
226 else if (toketype == OROR)
227 yylval.ival = OP_ORASSIGN;
228 else if (toketype == DORDOR)
229 yylval.ival = OP_DORASSIGN;
237 * When Perl expects an operator and finds something else, no_op
238 * prints the warning. It always prints "<something> found where
239 * operator expected. It prints "Missing semicolon on previous line?"
240 * if the surprise occurs at the start of the line. "do you need to
241 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
242 * where the compiler doesn't know if foo is a method call or a function.
243 * It prints "Missing operator before end of line" if there's nothing
244 * after the missing operator, or "... before <...>" if there is something
245 * after the missing operator.
249 S_no_op(pTHX_ char *what, char *s)
251 char *oldbp = PL_bufptr;
252 bool is_first = (PL_oldbufptr == PL_linestart);
258 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
260 Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
261 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
263 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
264 if (t < PL_bufptr && isSPACE(*t))
265 Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
266 t - PL_oldoldbufptr, PL_oldoldbufptr);
270 Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
277 * Complain about missing quote/regexp/heredoc terminator.
278 * If it's called with (char *)NULL then it cauterizes the line buffer.
279 * If we're in a delimited string and the delimiter is a control
280 * character, it's reformatted into a two-char sequence like ^C.
285 S_missingterm(pTHX_ char *s)
290 char *nl = strrchr(s,'\n');
296 iscntrl(PL_multi_close)
298 PL_multi_close < 32 || PL_multi_close == 127
302 tmpbuf[1] = toCTRL(PL_multi_close);
308 *tmpbuf = (char)PL_multi_close;
312 q = strchr(s,'"') ? '\'' : '"';
313 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
321 Perl_deprecate(pTHX_ char *s)
323 if (ckWARN(WARN_DEPRECATED))
324 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
328 Perl_deprecate_old(pTHX_ char *s)
330 /* This function should NOT be called for any new deprecated warnings */
331 /* Use Perl_deprecate instead */
333 /* It is here to maintain backward compatibility with the pre-5.8 */
334 /* warnings category hierarchy. The "deprecated" category used to */
335 /* live under the "syntax" category. It is now a top-level category */
336 /* in its own right. */
338 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
339 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
340 "Use of %s is deprecated", s);
345 * Deprecate a comma-less variable list.
351 deprecate_old("comma-less variable list");
355 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
356 * utf16-to-utf8-reversed.
359 #ifdef PERL_CR_FILTER
363 register char *s = SvPVX(sv);
364 register char *e = s + SvCUR(sv);
365 /* outer loop optimized to do nothing if there are no CR-LFs */
367 if (*s++ == '\r' && *s == '\n') {
368 /* hit a CR-LF, need to copy the rest */
369 register char *d = s - 1;
372 if (*s == '\r' && s[1] == '\n')
383 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
385 I32 count = FILTER_READ(idx+1, sv, maxlen);
386 if (count > 0 && !maxlen)
394 * Initialize variables. Uses the Perl save_stack to save its state (for
395 * recursive calls to the parser).
399 Perl_lex_start(pTHX_ SV *line)
404 SAVEI32(PL_lex_dojoin);
405 SAVEI32(PL_lex_brackets);
406 SAVEI32(PL_lex_casemods);
407 SAVEI32(PL_lex_starts);
408 SAVEI32(PL_lex_state);
409 SAVEVPTR(PL_lex_inpat);
410 SAVEI32(PL_lex_inwhat);
411 if (PL_lex_state == LEX_KNOWNEXT) {
412 I32 toke = PL_nexttoke;
413 while (--toke >= 0) {
414 SAVEI32(PL_nexttype[toke]);
415 SAVEVPTR(PL_nextval[toke]);
417 SAVEI32(PL_nexttoke);
419 SAVECOPLINE(PL_curcop);
422 SAVEPPTR(PL_oldbufptr);
423 SAVEPPTR(PL_oldoldbufptr);
424 SAVEPPTR(PL_last_lop);
425 SAVEPPTR(PL_last_uni);
426 SAVEPPTR(PL_linestart);
427 SAVESPTR(PL_linestr);
428 SAVEGENERICPV(PL_lex_brackstack);
429 SAVEGENERICPV(PL_lex_casestack);
430 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
431 SAVESPTR(PL_lex_stuff);
432 SAVEI32(PL_lex_defer);
433 SAVEI32(PL_sublex_info.sub_inwhat);
434 SAVESPTR(PL_lex_repl);
436 SAVEINT(PL_lex_expect);
438 PL_lex_state = LEX_NORMAL;
442 New(899, PL_lex_brackstack, 120, char);
443 New(899, PL_lex_casestack, 12, char);
445 *PL_lex_casestack = '\0';
448 PL_lex_stuff = Nullsv;
449 PL_lex_repl = Nullsv;
453 PL_sublex_info.sub_inwhat = 0;
455 if (SvREADONLY(PL_linestr))
456 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
457 s = SvPV(PL_linestr, len);
458 if (!len || s[len-1] != ';') {
459 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
460 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
461 sv_catpvn(PL_linestr, "\n;", 2);
463 SvTEMP_off(PL_linestr);
464 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
465 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
466 PL_last_lop = PL_last_uni = Nullch;
472 * Finalizer for lexing operations. Must be called when the parser is
473 * done with the lexer.
479 PL_doextract = FALSE;
484 * This subroutine has nothing to do with tilting, whether at windmills
485 * or pinball tables. Its name is short for "increment line". It
486 * increments the current line number in CopLINE(PL_curcop) and checks
487 * to see whether the line starts with a comment of the form
488 * # line 500 "foo.pm"
489 * If so, it sets the current line number and file to the values in the comment.
493 S_incline(pTHX_ char *s)
500 CopLINE_inc(PL_curcop);
503 while (SPACE_OR_TAB(*s)) s++;
504 if (strnEQ(s, "line", 4))
508 if (SPACE_OR_TAB(*s))
512 while (SPACE_OR_TAB(*s)) s++;
518 while (SPACE_OR_TAB(*s))
520 if (*s == '"' && (t = strchr(s+1, '"'))) {
525 for (t = s; !isSPACE(*t); t++) ;
528 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
530 if (*e != '\n' && *e != '\0')
531 return; /* false alarm */
536 CopFILE_free(PL_curcop);
537 CopFILE_set(PL_curcop, s);
540 CopLINE_set(PL_curcop, atoi(n)-1);
545 * Called to gobble the appropriate amount and type of whitespace.
546 * Skips comments as well.
550 S_skipspace(pTHX_ register char *s)
552 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
553 while (s < PL_bufend && SPACE_OR_TAB(*s))
559 SSize_t oldprevlen, oldoldprevlen;
560 SSize_t oldloplen = 0, oldunilen = 0;
561 while (s < PL_bufend && isSPACE(*s)) {
562 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
567 if (s < PL_bufend && *s == '#') {
568 while (s < PL_bufend && *s != '\n')
572 if (PL_in_eval && !PL_rsfp) {
579 /* only continue to recharge the buffer if we're at the end
580 * of the buffer, we're not reading from a source filter, and
581 * we're in normal lexing mode
583 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
584 PL_lex_state == LEX_FORMLINE)
587 /* try to recharge the buffer */
588 if ((s = filter_gets(PL_linestr, PL_rsfp,
589 (prevlen = SvCUR(PL_linestr)))) == Nullch)
591 /* end of file. Add on the -p or -n magic */
592 if (PL_minus_n || PL_minus_p) {
593 sv_setpv(PL_linestr,PL_minus_p ?
594 ";}continue{print or die qq(-p destination: $!\\n)" :
596 sv_catpv(PL_linestr,";}");
597 PL_minus_n = PL_minus_p = 0;
600 sv_setpv(PL_linestr,";");
602 /* reset variables for next time we lex */
603 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
605 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
606 PL_last_lop = PL_last_uni = Nullch;
608 /* Close the filehandle. Could be from -P preprocessor,
609 * STDIN, or a regular file. If we were reading code from
610 * STDIN (because the commandline held no -e or filename)
611 * then we don't close it, we reset it so the code can
612 * read from STDIN too.
615 if (PL_preprocess && !PL_in_eval)
616 (void)PerlProc_pclose(PL_rsfp);
617 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
618 PerlIO_clearerr(PL_rsfp);
620 (void)PerlIO_close(PL_rsfp);
625 /* not at end of file, so we only read another line */
626 /* make corresponding updates to old pointers, for yyerror() */
627 oldprevlen = PL_oldbufptr - PL_bufend;
628 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
630 oldunilen = PL_last_uni - PL_bufend;
632 oldloplen = PL_last_lop - PL_bufend;
633 PL_linestart = PL_bufptr = s + prevlen;
634 PL_bufend = s + SvCUR(PL_linestr);
636 PL_oldbufptr = s + oldprevlen;
637 PL_oldoldbufptr = s + oldoldprevlen;
639 PL_last_uni = s + oldunilen;
641 PL_last_lop = s + oldloplen;
644 /* debugger active and we're not compiling the debugger code,
645 * so store the line into the debugger's array of lines
647 if (PERLDB_LINE && PL_curstash != PL_debstash) {
648 SV *sv = NEWSV(85,0);
650 sv_upgrade(sv, SVt_PVMG);
651 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
654 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
661 * Check the unary operators to ensure there's no ambiguity in how they're
662 * used. An ambiguous piece of code would be:
664 * This doesn't mean rand() + 5. Because rand() is a unary operator,
665 * the +5 is its argument.
674 if (PL_oldoldbufptr != PL_last_uni)
676 while (isSPACE(*PL_last_uni))
678 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
679 if ((t = strchr(s, '(')) && t < PL_bufptr)
681 if (ckWARN_d(WARN_AMBIGUOUS)){
684 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
685 "Warning: Use of \"%s\" without parentheses is ambiguous",
692 * LOP : macro to build a list operator. Its behaviour has been replaced
693 * with a subroutine, S_lop() for which LOP is just another name.
696 #define LOP(f,x) return lop(f,x,s)
700 * Build a list operator (or something that might be one). The rules:
701 * - if we have a next token, then it's a list operator [why?]
702 * - if the next thing is an opening paren, then it's a function
703 * - else it's a list operator
707 S_lop(pTHX_ I32 f, int x, char *s)
714 PL_last_lop = PL_oldbufptr;
715 PL_last_lop_op = (OPCODE)f;
729 * When the lexer realizes it knows the next token (for instance,
730 * it is reordering tokens for the parser) then it can call S_force_next
731 * to know what token to return the next time the lexer is called. Caller
732 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
733 * handles the token correctly.
737 S_force_next(pTHX_ I32 type)
739 PL_nexttype[PL_nexttoke] = type;
741 if (PL_lex_state != LEX_KNOWNEXT) {
742 PL_lex_defer = PL_lex_state;
743 PL_lex_expect = PL_expect;
744 PL_lex_state = LEX_KNOWNEXT;
750 * When the lexer knows the next thing is a word (for instance, it has
751 * just seen -> and it knows that the next char is a word char, then
752 * it calls S_force_word to stick the next word into the PL_next lookahead.
755 * char *start : buffer position (must be within PL_linestr)
756 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
757 * int check_keyword : if true, Perl checks to make sure the word isn't
758 * a keyword (do this if the word is a label, e.g. goto FOO)
759 * int allow_pack : if true, : characters will also be allowed (require,
761 * int allow_initial_tick : used by the "sub" lexer only.
765 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
770 start = skipspace(start);
772 if (isIDFIRST_lazy_if(s,UTF) ||
773 (allow_pack && *s == ':') ||
774 (allow_initial_tick && *s == '\'') )
776 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
777 if (check_keyword && keyword(PL_tokenbuf, len))
779 if (token == METHOD) {
784 PL_expect = XOPERATOR;
787 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
788 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
789 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
790 SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke].opval)->op_sv);
798 * Called when the lexer wants $foo *foo &foo etc, but the program
799 * text only contains the "foo" portion. The first argument is a pointer
800 * to the "foo", and the second argument is the type symbol to prefix.
801 * Forces the next token to be a "WORD".
802 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
806 S_force_ident(pTHX_ register char *s, int kind)
809 OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
810 PL_nextval[PL_nexttoke].opval = o;
813 o->op_private = OPpCONST_ENTERED;
814 /* XXX see note in pp_entereval() for why we forgo typo
815 warnings if the symbol must be introduced in an eval.
817 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
818 kind == '$' ? SVt_PV :
819 kind == '@' ? SVt_PVAV :
820 kind == '%' ? SVt_PVHV :
828 Perl_str_to_version(pTHX_ SV *sv)
833 char *start = SvPVx(sv,len);
834 bool utf = SvUTF8(sv) ? TRUE : FALSE;
835 char *end = start + len;
836 while (start < end) {
840 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
845 retval += ((NV)n)/nshift;
854 * Forces the next token to be a version number.
855 * If the next token appears to be an invalid version number, (e.g. "v2b"),
856 * and if "guessing" is TRUE, then no new token is created (and the caller
857 * must use an alternative parsing method).
861 S_force_version(pTHX_ char *s, int guessing)
863 OP *version = Nullop;
872 while (isDIGIT(*d) || *d == '_' || *d == '.')
874 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
876 s = scan_num(s, &yylval);
877 version = yylval.opval;
878 ver = cSVOPx(version)->op_sv;
879 if (SvPOK(ver) && !SvNIOK(ver)) {
880 (void)SvUPGRADE(ver, SVt_PVNV);
881 SvNVX(ver) = str_to_version(ver);
882 SvNOK_on(ver); /* hint that it is a version */
889 /* NOTE: The parser sees the package name and the VERSION swapped */
890 PL_nextval[PL_nexttoke].opval = version;
898 * Tokenize a quoted string passed in as an SV. It finds the next
899 * chunk, up to end of string or a backslash. It may make a new
900 * SV containing that chunk (if HINT_NEW_STRING is on). It also
905 S_tokeq(pTHX_ SV *sv)
916 s = SvPV_force(sv, len);
917 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
920 while (s < send && *s != '\\')
925 if ( PL_hints & HINT_NEW_STRING ) {
926 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
932 if (s + 1 < send && (s[1] == '\\'))
933 s++; /* all that, just for this */
938 SvCUR_set(sv, d - SvPVX(sv));
940 if ( PL_hints & HINT_NEW_STRING )
941 return new_constant(NULL, 0, "q", sv, pv, "q");
946 * Now come three functions related to double-quote context,
947 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
948 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
949 * interact with PL_lex_state, and create fake ( ... ) argument lists
950 * to handle functions and concatenation.
951 * They assume that whoever calls them will be setting up a fake
952 * join call, because each subthing puts a ',' after it. This lets
955 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
957 * (I'm not sure whether the spurious commas at the end of lcfirst's
958 * arguments and join's arguments are created or not).
963 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
965 * Pattern matching will set PL_lex_op to the pattern-matching op to
966 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
968 * OP_CONST and OP_READLINE are easy--just make the new op and return.
970 * Everything else becomes a FUNC.
972 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
973 * had an OP_CONST or OP_READLINE). This just sets us up for a
974 * call to S_sublex_push().
980 register I32 op_type = yylval.ival;
982 if (op_type == OP_NULL) {
983 yylval.opval = PL_lex_op;
987 if (op_type == OP_CONST || op_type == OP_READLINE) {
988 SV *sv = tokeq(PL_lex_stuff);
990 if (SvTYPE(sv) == SVt_PVIV) {
991 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
997 nsv = newSVpvn(p, len);
1003 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1004 PL_lex_stuff = Nullsv;
1005 /* Allow <FH> // "foo" */
1006 if (op_type == OP_READLINE)
1007 PL_expect = XTERMORDORDOR;
1011 PL_sublex_info.super_state = PL_lex_state;
1012 PL_sublex_info.sub_inwhat = op_type;
1013 PL_sublex_info.sub_op = PL_lex_op;
1014 PL_lex_state = LEX_INTERPPUSH;
1018 yylval.opval = PL_lex_op;
1028 * Create a new scope to save the lexing state. The scope will be
1029 * ended in S_sublex_done. Returns a '(', starting the function arguments
1030 * to the uc, lc, etc. found before.
1031 * Sets PL_lex_state to LEX_INTERPCONCAT.
1039 PL_lex_state = PL_sublex_info.super_state;
1040 SAVEI32(PL_lex_dojoin);
1041 SAVEI32(PL_lex_brackets);
1042 SAVEI32(PL_lex_casemods);
1043 SAVEI32(PL_lex_starts);
1044 SAVEI32(PL_lex_state);
1045 SAVEVPTR(PL_lex_inpat);
1046 SAVEI32(PL_lex_inwhat);
1047 SAVECOPLINE(PL_curcop);
1048 SAVEPPTR(PL_bufptr);
1049 SAVEPPTR(PL_bufend);
1050 SAVEPPTR(PL_oldbufptr);
1051 SAVEPPTR(PL_oldoldbufptr);
1052 SAVEPPTR(PL_last_lop);
1053 SAVEPPTR(PL_last_uni);
1054 SAVEPPTR(PL_linestart);
1055 SAVESPTR(PL_linestr);
1056 SAVEGENERICPV(PL_lex_brackstack);
1057 SAVEGENERICPV(PL_lex_casestack);
1059 PL_linestr = PL_lex_stuff;
1060 PL_lex_stuff = Nullsv;
1062 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1063 = SvPVX(PL_linestr);
1064 PL_bufend += SvCUR(PL_linestr);
1065 PL_last_lop = PL_last_uni = Nullch;
1066 SAVEFREESV(PL_linestr);
1068 PL_lex_dojoin = FALSE;
1069 PL_lex_brackets = 0;
1070 New(899, PL_lex_brackstack, 120, char);
1071 New(899, PL_lex_casestack, 12, char);
1072 PL_lex_casemods = 0;
1073 *PL_lex_casestack = '\0';
1075 PL_lex_state = LEX_INTERPCONCAT;
1076 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1078 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1079 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1080 PL_lex_inpat = PL_sublex_info.sub_op;
1082 PL_lex_inpat = Nullop;
1089 * Restores lexer state after a S_sublex_push.
1095 if (!PL_lex_starts++) {
1096 SV *sv = newSVpvn("",0);
1097 if (SvUTF8(PL_linestr))
1099 PL_expect = XOPERATOR;
1100 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1104 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1105 PL_lex_state = LEX_INTERPCASEMOD;
1109 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1110 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1111 PL_linestr = PL_lex_repl;
1113 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1114 PL_bufend += SvCUR(PL_linestr);
1115 PL_last_lop = PL_last_uni = Nullch;
1116 SAVEFREESV(PL_linestr);
1117 PL_lex_dojoin = FALSE;
1118 PL_lex_brackets = 0;
1119 PL_lex_casemods = 0;
1120 *PL_lex_casestack = '\0';
1122 if (SvEVALED(PL_lex_repl)) {
1123 PL_lex_state = LEX_INTERPNORMAL;
1125 /* we don't clear PL_lex_repl here, so that we can check later
1126 whether this is an evalled subst; that means we rely on the
1127 logic to ensure sublex_done() is called again only via the
1128 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1131 PL_lex_state = LEX_INTERPCONCAT;
1132 PL_lex_repl = Nullsv;
1138 PL_bufend = SvPVX(PL_linestr);
1139 PL_bufend += SvCUR(PL_linestr);
1140 PL_expect = XOPERATOR;
1141 PL_sublex_info.sub_inwhat = 0;
1149 Extracts a pattern, double-quoted string, or transliteration. This
1152 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1153 processing a pattern (PL_lex_inpat is true), a transliteration
1154 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1156 Returns a pointer to the character scanned up to. Iff this is
1157 advanced from the start pointer supplied (ie if anything was
1158 successfully parsed), will leave an OP for the substring scanned
1159 in yylval. Caller must intuit reason for not parsing further
1160 by looking at the next characters herself.
1164 double-quoted style: \r and \n
1165 regexp special ones: \D \s
1167 backrefs: \1 (deprecated in substitution replacements)
1168 case and quoting: \U \Q \E
1169 stops on @ and $, but not for $ as tail anchor
1171 In transliterations:
1172 characters are VERY literal, except for - not at the start or end
1173 of the string, which indicates a range. scan_const expands the
1174 range to the full set of intermediate characters.
1176 In double-quoted strings:
1178 double-quoted style: \r and \n
1180 backrefs: \1 (deprecated)
1181 case and quoting: \U \Q \E
1184 scan_const does *not* construct ops to handle interpolated strings.
1185 It stops processing as soon as it finds an embedded $ or @ variable
1186 and leaves it to the caller to work out what's going on.
1188 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1190 $ in pattern could be $foo or could be tail anchor. Assumption:
1191 it's a tail anchor if $ is the last thing in the string, or if it's
1192 followed by one of ")| \n\t"
1194 \1 (backreferences) are turned into $1
1196 The structure of the code is
1197 while (there's a character to process) {
1198 handle transliteration ranges
1199 skip regexp comments
1200 skip # initiated comments in //x patterns
1201 check for embedded @foo
1202 check for embedded scalars
1204 leave intact backslashes from leave (below)
1205 deprecate \1 in strings and sub replacements
1206 handle string-changing backslashes \l \U \Q \E, etc.
1207 switch (what was escaped) {
1208 handle - in a transliteration (becomes a literal -)
1209 handle \132 octal characters
1210 handle 0x15 hex characters
1211 handle \cV (control V)
1212 handle printf backslashes (\f, \r, \n, etc)
1214 } (end if backslash)
1215 } (end while character to read)
1220 S_scan_const(pTHX_ char *start)
1222 register char *send = PL_bufend; /* end of the constant */
1223 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1224 register char *s = start; /* start of the constant */
1225 register char *d = SvPVX(sv); /* destination for copies */
1226 bool dorange = FALSE; /* are we in a translit range? */
1227 bool didrange = FALSE; /* did we just finish a range? */
1228 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1229 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1232 const char *leaveit = /* set of acceptably-backslashed characters */
1234 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1237 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1238 /* If we are doing a trans and we know we want UTF8 set expectation */
1239 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1240 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1244 while (s < send || dorange) {
1245 /* get transliterations out of the way (they're most literal) */
1246 if (PL_lex_inwhat == OP_TRANS) {
1247 /* expand a range A-Z to the full set of characters. AIE! */
1249 I32 i; /* current expanded character */
1250 I32 min; /* first character in range */
1251 I32 max; /* last character in range */
1254 char *c = (char*)utf8_hop((U8*)d, -1);
1258 *c = (char)UTF_TO_NATIVE(0xff);
1259 /* mark the range as done, and continue */
1265 i = d - SvPVX(sv); /* remember current offset */
1266 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1267 d = SvPVX(sv) + i; /* refresh d after realloc */
1268 d -= 2; /* eat the first char and the - */
1270 min = (U8)*d; /* first char in range */
1271 max = (U8)d[1]; /* last char in range */
1275 "Invalid range \"%c-%c\" in transliteration operator",
1276 (char)min, (char)max);
1280 if ((isLOWER(min) && isLOWER(max)) ||
1281 (isUPPER(min) && isUPPER(max))) {
1283 for (i = min; i <= max; i++)
1285 *d++ = NATIVE_TO_NEED(has_utf8,i);
1287 for (i = min; i <= max; i++)
1289 *d++ = NATIVE_TO_NEED(has_utf8,i);
1294 for (i = min; i <= max; i++)
1297 /* mark the range as done, and continue */
1303 /* range begins (ignore - as first or last char) */
1304 else if (*s == '-' && s+1 < send && s != start) {
1306 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1309 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1321 /* if we get here, we're not doing a transliteration */
1323 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1324 except for the last char, which will be done separately. */
1325 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1327 while (s < send && *s != ')')
1328 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1330 else if (s[2] == '{' /* This should match regcomp.c */
1331 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1334 char *regparse = s + (s[2] == '{' ? 3 : 4);
1337 while (count && (c = *regparse)) {
1338 if (c == '\\' && regparse[1])
1346 if (*regparse != ')') {
1347 regparse--; /* Leave one char for continuation. */
1348 yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1350 while (s < regparse)
1351 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1355 /* likewise skip #-initiated comments in //x patterns */
1356 else if (*s == '#' && PL_lex_inpat &&
1357 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1358 while (s+1 < send && *s != '\n')
1359 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1362 /* check for embedded arrays
1363 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1365 else if (*s == '@' && s[1]
1366 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1369 /* check for embedded scalars. only stop if we're sure it's a
1372 else if (*s == '$') {
1373 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1375 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1376 break; /* in regexp, $ might be tail anchor */
1379 /* End of else if chain - OP_TRANS rejoin rest */
1382 if (*s == '\\' && s+1 < send) {
1385 /* some backslashes we leave behind */
1386 if (*leaveit && *s && strchr(leaveit, *s)) {
1387 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1388 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1392 /* deprecate \1 in strings and substitution replacements */
1393 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1394 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1396 if (ckWARN(WARN_SYNTAX))
1397 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1402 /* string-change backslash escapes */
1403 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1408 /* if we get here, it's either a quoted -, or a digit */
1411 /* quoted - in transliterations */
1413 if (PL_lex_inwhat == OP_TRANS) {
1420 if (ckWARN(WARN_MISC) &&
1423 Perl_warner(aTHX_ packWARN(WARN_MISC),
1424 "Unrecognized escape \\%c passed through",
1426 /* default action is to copy the quoted character */
1427 goto default_action;
1430 /* \132 indicates an octal constant */
1431 case '0': case '1': case '2': case '3':
1432 case '4': case '5': case '6': case '7':
1436 uv = grok_oct(s, &len, &flags, NULL);
1439 goto NUM_ESCAPE_INSERT;
1441 /* \x24 indicates a hex constant */
1445 char* e = strchr(s, '}');
1446 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1447 PERL_SCAN_DISALLOW_PREFIX;
1452 yyerror("Missing right brace on \\x{}");
1456 uv = grok_hex(s, &len, &flags, NULL);
1462 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1463 uv = grok_hex(s, &len, &flags, NULL);
1469 /* Insert oct or hex escaped character.
1470 * There will always enough room in sv since such
1471 * escapes will be longer than any UTF-8 sequence
1472 * they can end up as. */
1474 /* We need to map to chars to ASCII before doing the tests
1477 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1478 if (!has_utf8 && uv > 255) {
1479 /* Might need to recode whatever we have
1480 * accumulated so far if it contains any
1483 * (Can't we keep track of that and avoid
1484 * this rescan? --jhi)
1488 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1489 if (!NATIVE_IS_INVARIANT(*c)) {
1494 STRLEN offset = d - SvPVX(sv);
1496 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1500 while (src >= (U8 *)SvPVX(sv)) {
1501 if (!NATIVE_IS_INVARIANT(*src)) {
1502 U8 ch = NATIVE_TO_ASCII(*src);
1503 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1504 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1514 if (has_utf8 || uv > 255) {
1515 d = (char*)uvchr_to_utf8((U8*)d, uv);
1517 if (PL_lex_inwhat == OP_TRANS &&
1518 PL_sublex_info.sub_op) {
1519 PL_sublex_info.sub_op->op_private |=
1520 (PL_lex_repl ? OPpTRANS_FROM_UTF
1533 /* \N{LATIN SMALL LETTER A} is a named character */
1537 char* e = strchr(s, '}');
1543 yyerror("Missing right brace on \\N{}");
1547 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1549 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1550 PERL_SCAN_DISALLOW_PREFIX;
1553 uv = grok_hex(s, &len, &flags, NULL);
1555 goto NUM_ESCAPE_INSERT;
1557 res = newSVpvn(s + 1, e - s - 1);
1558 res = new_constant( Nullch, 0, "charnames",
1559 res, Nullsv, "\\N{...}" );
1561 sv_utf8_upgrade(res);
1562 str = SvPV(res,len);
1563 #ifdef EBCDIC_NEVER_MIND
1564 /* charnames uses pack U and that has been
1565 * recently changed to do the below uni->native
1566 * mapping, so this would be redundant (and wrong,
1567 * the code point would be doubly converted).
1568 * But leave this in just in case the pack U change
1569 * gets revoked, but the semantics is still
1570 * desireable for charnames. --jhi */
1572 UV uv = utf8_to_uvchr((U8*)str, 0);
1575 U8 tmpbuf[UTF8_MAXLEN+1], *d;
1577 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1578 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1579 str = SvPV(res, len);
1583 if (!has_utf8 && SvUTF8(res)) {
1584 char *ostart = SvPVX(sv);
1585 SvCUR_set(sv, d - ostart);
1588 sv_utf8_upgrade(sv);
1589 /* this just broke our allocation above... */
1590 SvGROW(sv, (STRLEN)(send - start));
1591 d = SvPVX(sv) + SvCUR(sv);
1594 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1595 char *odest = SvPVX(sv);
1597 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1598 d = SvPVX(sv) + (d - odest);
1600 Copy(str, d, len, char);
1607 yyerror("Missing braces on \\N{}");
1610 /* \c is a control character */
1619 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1622 yyerror("Missing control char name in \\c");
1626 /* printf-style backslashes, formfeeds, newlines, etc */
1628 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1631 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1634 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1637 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1640 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1643 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1646 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1652 } /* end if (backslash) */
1655 /* If we started with encoded form, or already know we want it
1656 and then encode the next character */
1657 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1659 UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1660 STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1663 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1664 STRLEN off = d - SvPVX(sv);
1665 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1667 d = (char*)uvchr_to_utf8((U8*)d, uv);
1671 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1673 } /* while loop to process each character */
1675 /* terminate the string and set up the sv */
1677 SvCUR_set(sv, d - SvPVX(sv));
1678 if (SvCUR(sv) >= SvLEN(sv))
1679 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1682 if (PL_encoding && !has_utf8) {
1683 sv_recode_to_utf8(sv, PL_encoding);
1689 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1690 PL_sublex_info.sub_op->op_private |=
1691 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1695 /* shrink the sv if we allocated more than we used */
1696 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1697 SvLEN_set(sv, SvCUR(sv) + 1);
1698 Renew(SvPVX(sv), SvLEN(sv), char);
1701 /* return the substring (via yylval) only if we parsed anything */
1702 if (s > PL_bufptr) {
1703 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1704 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1706 ( PL_lex_inwhat == OP_TRANS
1708 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1711 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1718 * Returns TRUE if there's more to the expression (e.g., a subscript),
1721 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1723 * ->[ and ->{ return TRUE
1724 * { and [ outside a pattern are always subscripts, so return TRUE
1725 * if we're outside a pattern and it's not { or [, then return FALSE
1726 * if we're in a pattern and the first char is a {
1727 * {4,5} (any digits around the comma) returns FALSE
1728 * if we're in a pattern and the first char is a [
1730 * [SOMETHING] has a funky algorithm to decide whether it's a
1731 * character class or not. It has to deal with things like
1732 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1733 * anything else returns TRUE
1736 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1739 S_intuit_more(pTHX_ register char *s)
1741 if (PL_lex_brackets)
1743 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1745 if (*s != '{' && *s != '[')
1750 /* In a pattern, so maybe we have {n,m}. */
1767 /* On the other hand, maybe we have a character class */
1770 if (*s == ']' || *s == '^')
1773 /* this is terrifying, and it works */
1774 int weight = 2; /* let's weigh the evidence */
1776 unsigned char un_char = 255, last_un_char;
1777 char *send = strchr(s,']');
1778 char tmpbuf[sizeof PL_tokenbuf * 4];
1780 if (!send) /* has to be an expression */
1783 Zero(seen,256,char);
1786 else if (isDIGIT(*s)) {
1788 if (isDIGIT(s[1]) && s[2] == ']')
1794 for (; s < send; s++) {
1795 last_un_char = un_char;
1796 un_char = (unsigned char)*s;
1801 weight -= seen[un_char] * 10;
1802 if (isALNUM_lazy_if(s+1,UTF)) {
1803 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1804 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1809 else if (*s == '$' && s[1] &&
1810 strchr("[#!%*<>()-=",s[1])) {
1811 if (/*{*/ strchr("])} =",s[2]))
1820 if (strchr("wds]",s[1]))
1822 else if (seen['\''] || seen['"'])
1824 else if (strchr("rnftbxcav",s[1]))
1826 else if (isDIGIT(s[1])) {
1828 while (s[1] && isDIGIT(s[1]))
1838 if (strchr("aA01! ",last_un_char))
1840 if (strchr("zZ79~",s[1]))
1842 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1843 weight -= 5; /* cope with negative subscript */
1846 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1847 isALPHA(*s) && s[1] && isALPHA(s[1])) {
1852 if (keyword(tmpbuf, d - tmpbuf))
1855 if (un_char == last_un_char + 1)
1857 weight -= seen[un_char];
1862 if (weight >= 0) /* probably a character class */
1872 * Does all the checking to disambiguate
1874 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
1875 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1877 * First argument is the stuff after the first token, e.g. "bar".
1879 * Not a method if bar is a filehandle.
1880 * Not a method if foo is a subroutine prototyped to take a filehandle.
1881 * Not a method if it's really "Foo $bar"
1882 * Method if it's "foo $bar"
1883 * Not a method if it's really "print foo $bar"
1884 * Method if it's really "foo package::" (interpreted as package->foo)
1885 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
1886 * Not a method if bar is a filehandle or package, but is quoted with
1891 S_intuit_method(pTHX_ char *start, GV *gv)
1893 char *s = start + (*start == '$');
1894 char tmpbuf[sizeof PL_tokenbuf];
1902 if ((cv = GvCVu(gv))) {
1903 char *proto = SvPVX(cv);
1913 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1914 /* start is the beginning of the possible filehandle/object,
1915 * and s is the end of it
1916 * tmpbuf is a copy of it
1919 if (*start == '$') {
1920 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1925 return *s == '(' ? FUNCMETH : METHOD;
1927 if (!keyword(tmpbuf, len)) {
1928 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1933 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1934 if (indirgv && GvCVu(indirgv))
1936 /* filehandle or package name makes it a method */
1937 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1939 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1940 return 0; /* no assumptions -- "=>" quotes bearword */
1942 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1943 newSVpvn(tmpbuf,len));
1944 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1948 return *s == '(' ? FUNCMETH : METHOD;
1956 * Return a string of Perl code to load the debugger. If PERL5DB
1957 * is set, it will return the contents of that, otherwise a
1958 * compile-time require of perl5db.pl.
1965 char *pdb = PerlEnv_getenv("PERL5DB");
1969 SETERRNO(0,SS_NORMAL);
1970 return "BEGIN { require 'perl5db.pl' }";
1976 /* Encoded script support. filter_add() effectively inserts a
1977 * 'pre-processing' function into the current source input stream.
1978 * Note that the filter function only applies to the current source file
1979 * (e.g., it will not affect files 'require'd or 'use'd by this one).
1981 * The datasv parameter (which may be NULL) can be used to pass
1982 * private data to this instance of the filter. The filter function
1983 * can recover the SV using the FILTER_DATA macro and use it to
1984 * store private buffers and state information.
1986 * The supplied datasv parameter is upgraded to a PVIO type
1987 * and the IoDIRP/IoANY field is used to store the function pointer,
1988 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1989 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1990 * private use must be set using malloc'd pointers.
1994 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1999 if (!PL_rsfp_filters)
2000 PL_rsfp_filters = newAV();
2002 datasv = NEWSV(255,0);
2003 if (!SvUPGRADE(datasv, SVt_PVIO))
2004 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
2005 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
2006 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2007 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2008 (void*)funcp, SvPV_nolen(datasv)));
2009 av_unshift(PL_rsfp_filters, 1);
2010 av_store(PL_rsfp_filters, 0, datasv) ;
2015 /* Delete most recently added instance of this filter function. */
2017 Perl_filter_del(pTHX_ filter_t funcp)
2020 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2021 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2023 /* if filter is on top of stack (usual case) just pop it off */
2024 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2025 if (IoANY(datasv) == (void *)funcp) {
2026 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2027 IoANY(datasv) = (void *)NULL;
2028 sv_free(av_pop(PL_rsfp_filters));
2032 /* we need to search for the correct entry and clear it */
2033 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2037 /* Invoke the n'th filter function for the current rsfp. */
2039 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2042 /* 0 = read one text line */
2047 if (!PL_rsfp_filters)
2049 if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
2050 /* Provide a default input filter to make life easy. */
2051 /* Note that we append to the line. This is handy. */
2052 DEBUG_P(PerlIO_printf(Perl_debug_log,
2053 "filter_read %d: from rsfp\n", idx));
2057 int old_len = SvCUR(buf_sv) ;
2059 /* ensure buf_sv is large enough */
2060 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2061 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2062 if (PerlIO_error(PL_rsfp))
2063 return -1; /* error */
2065 return 0 ; /* end of file */
2067 SvCUR_set(buf_sv, old_len + len) ;
2070 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2071 if (PerlIO_error(PL_rsfp))
2072 return -1; /* error */
2074 return 0 ; /* end of file */
2077 return SvCUR(buf_sv);
2079 /* Skip this filter slot if filter has been deleted */
2080 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2081 DEBUG_P(PerlIO_printf(Perl_debug_log,
2082 "filter_read %d: skipped (filter deleted)\n",
2084 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2086 /* Get function pointer hidden within datasv */
2087 funcp = (filter_t)IoANY(datasv);
2088 DEBUG_P(PerlIO_printf(Perl_debug_log,
2089 "filter_read %d: via function %p (%s)\n",
2090 idx, (void*)funcp, SvPV_nolen(datasv)));
2091 /* Call function. The function is expected to */
2092 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2093 /* Return: <0:error, =0:eof, >0:not eof */
2094 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2098 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2100 #ifdef PERL_CR_FILTER
2101 if (!PL_rsfp_filters) {
2102 filter_add(S_cr_textfilter,NULL);
2105 if (PL_rsfp_filters) {
2108 SvCUR_set(sv, 0); /* start with empty line */
2109 if (FILTER_READ(0, sv, 0) > 0)
2110 return ( SvPVX(sv) ) ;
2115 return (sv_gets(sv, fp, append));
2119 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2123 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2127 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2128 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2130 return GvHV(gv); /* Foo:: */
2133 /* use constant CLASS => 'MyClass' */
2134 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2136 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2137 pkgname = SvPV_nolen(sv);
2141 return gv_stashpv(pkgname, FALSE);
2145 static char* exp_name[] =
2146 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2147 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2154 Works out what to call the token just pulled out of the input
2155 stream. The yacc parser takes care of taking the ops we return and
2156 stitching them into a tree.
2162 if read an identifier
2163 if we're in a my declaration
2164 croak if they tried to say my($foo::bar)
2165 build the ops for a my() declaration
2166 if it's an access to a my() variable
2167 are we in a sort block?
2168 croak if my($a); $a <=> $b
2169 build ops for access to a my() variable
2170 if in a dq string, and they've said @foo and we can't find @foo
2172 build ops for a bareword
2173 if we already built the token before, use it.
2176 #ifdef USE_PURE_BISON
2178 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2183 yylval_pointer[yyactlevel] = lvalp;
2184 yychar_pointer[yyactlevel] = lcharp;
2185 if (yyactlevel >= YYMAXLEVEL)
2186 Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2188 r = Perl_yylex(aTHX);
2198 #pragma segment Perl_yylex
2210 I32 orig_keyword = 0;
2212 /* check if there's an identifier for us to look at */
2213 if (PL_pending_ident)
2214 return S_pending_ident(aTHX);
2216 /* no identifier pending identification */
2218 switch (PL_lex_state) {
2220 case LEX_NORMAL: /* Some compilers will produce faster */
2221 case LEX_INTERPNORMAL: /* code if we comment these out. */
2225 /* when we've already built the next token, just pull it out of the queue */
2228 yylval = PL_nextval[PL_nexttoke];
2230 PL_lex_state = PL_lex_defer;
2231 PL_expect = PL_lex_expect;
2232 PL_lex_defer = LEX_NORMAL;
2234 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2235 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2236 (IV)PL_nexttype[PL_nexttoke]); });
2238 return(PL_nexttype[PL_nexttoke]);
2240 /* interpolated case modifiers like \L \U, including \Q and \E.
2241 when we get here, PL_bufptr is at the \
2243 case LEX_INTERPCASEMOD:
2245 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2246 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2248 /* handle \E or end of string */
2249 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2253 if (PL_lex_casemods) {
2254 oldmod = PL_lex_casestack[--PL_lex_casemods];
2255 PL_lex_casestack[PL_lex_casemods] = '\0';
2257 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2259 PL_lex_state = LEX_INTERPCONCAT;
2263 if (PL_bufptr != PL_bufend)
2265 PL_lex_state = LEX_INTERPCONCAT;
2269 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2270 "### Saw case modifier at '%s'\n", PL_bufptr); });
2272 if (s[1] == '\\' && s[2] == 'E') {
2274 PL_lex_state = LEX_INTERPCONCAT;
2278 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2279 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2280 if (strchr("LU", *s) &&
2281 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2282 PL_lex_casestack[--PL_lex_casemods] = '\0';
2285 if (PL_lex_casemods > 10)
2286 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2287 PL_lex_casestack[PL_lex_casemods++] = *s;
2288 PL_lex_casestack[PL_lex_casemods] = '\0';
2289 PL_lex_state = LEX_INTERPCONCAT;
2290 PL_nextval[PL_nexttoke].ival = 0;
2293 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2295 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2297 PL_nextval[PL_nexttoke].ival = OP_LC;
2299 PL_nextval[PL_nexttoke].ival = OP_UC;
2301 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2303 Perl_croak(aTHX_ "panic: yylex");
2307 if (PL_lex_starts) {
2316 case LEX_INTERPPUSH:
2317 return sublex_push();
2319 case LEX_INTERPSTART:
2320 if (PL_bufptr == PL_bufend)
2321 return sublex_done();
2322 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2323 "### Interpolated variable at '%s'\n", PL_bufptr); });
2325 PL_lex_dojoin = (*PL_bufptr == '@');
2326 PL_lex_state = LEX_INTERPNORMAL;
2327 if (PL_lex_dojoin) {
2328 PL_nextval[PL_nexttoke].ival = 0;
2330 force_ident("\"", '$');
2331 PL_nextval[PL_nexttoke].ival = 0;
2333 PL_nextval[PL_nexttoke].ival = 0;
2335 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2338 if (PL_lex_starts++) {
2344 case LEX_INTERPENDMAYBE:
2345 if (intuit_more(PL_bufptr)) {
2346 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2352 if (PL_lex_dojoin) {
2353 PL_lex_dojoin = FALSE;
2354 PL_lex_state = LEX_INTERPCONCAT;
2357 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2358 && SvEVALED(PL_lex_repl))
2360 if (PL_bufptr != PL_bufend)
2361 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2362 PL_lex_repl = Nullsv;
2365 case LEX_INTERPCONCAT:
2367 if (PL_lex_brackets)
2368 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2370 if (PL_bufptr == PL_bufend)
2371 return sublex_done();
2373 if (SvIVX(PL_linestr) == '\'') {
2374 SV *sv = newSVsv(PL_linestr);
2377 else if ( PL_hints & HINT_NEW_RE )
2378 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2379 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2383 s = scan_const(PL_bufptr);
2385 PL_lex_state = LEX_INTERPCASEMOD;
2387 PL_lex_state = LEX_INTERPSTART;
2390 if (s != PL_bufptr) {
2391 PL_nextval[PL_nexttoke] = yylval;
2394 if (PL_lex_starts++)
2404 PL_lex_state = LEX_NORMAL;
2405 s = scan_formline(PL_bufptr);
2406 if (!PL_lex_formbrack)
2412 PL_oldoldbufptr = PL_oldbufptr;
2415 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2416 exp_name[PL_expect], s);
2422 if (isIDFIRST_lazy_if(s,UTF))
2424 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2427 goto fake_eof; /* emulate EOF on ^D or ^Z */
2432 if (PL_lex_brackets)
2433 yyerror("Missing right curly or square bracket");
2434 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2435 "### Tokener got EOF\n");
2439 if (s++ < PL_bufend)
2440 goto retry; /* ignore stray nulls */
2443 if (!PL_in_eval && !PL_preambled) {
2444 PL_preambled = TRUE;
2445 sv_setpv(PL_linestr,incl_perldb());
2446 if (SvCUR(PL_linestr))
2447 sv_catpv(PL_linestr,";");
2449 while(AvFILLp(PL_preambleav) >= 0) {
2450 SV *tmpsv = av_shift(PL_preambleav);
2451 sv_catsv(PL_linestr, tmpsv);
2452 sv_catpv(PL_linestr, ";");
2455 sv_free((SV*)PL_preambleav);
2456 PL_preambleav = NULL;
2458 if (PL_minus_n || PL_minus_p) {
2459 sv_catpv(PL_linestr, "LINE: while (<>) {");
2461 sv_catpv(PL_linestr,"chomp;");
2464 if (strchr("/'\"", *PL_splitstr)
2465 && strchr(PL_splitstr + 1, *PL_splitstr))
2466 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2469 s = "'~#\200\1'"; /* surely one char is unused...*/
2470 while (s[1] && strchr(PL_splitstr, *s)) s++;
2472 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2473 "q" + (delim == '\''), delim);
2474 for (s = PL_splitstr; *s; s++) {
2476 sv_catpvn(PL_linestr, "\\", 1);
2477 sv_catpvn(PL_linestr, s, 1);
2479 Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2483 sv_catpv(PL_linestr,"our @F=split(' ');");
2486 sv_catpv(PL_linestr, "\n");
2487 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2488 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2489 PL_last_lop = PL_last_uni = Nullch;
2490 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2491 SV *sv = NEWSV(85,0);
2493 sv_upgrade(sv, SVt_PVMG);
2494 sv_setsv(sv,PL_linestr);
2497 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2502 bof = PL_rsfp ? TRUE : FALSE;
2503 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2506 if (PL_preprocess && !PL_in_eval)
2507 (void)PerlProc_pclose(PL_rsfp);
2508 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2509 PerlIO_clearerr(PL_rsfp);
2511 (void)PerlIO_close(PL_rsfp);
2513 PL_doextract = FALSE;
2515 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2516 sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2517 sv_catpv(PL_linestr,";}");
2518 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2519 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2520 PL_last_lop = PL_last_uni = Nullch;
2521 PL_minus_n = PL_minus_p = 0;
2524 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2525 PL_last_lop = PL_last_uni = Nullch;
2526 sv_setpv(PL_linestr,"");
2527 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2529 /* if it looks like the start of a BOM, check if it in fact is */
2530 else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2531 #ifdef PERLIO_IS_STDIO
2532 # ifdef __GNU_LIBRARY__
2533 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2534 # define FTELL_FOR_PIPE_IS_BROKEN
2538 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2539 # define FTELL_FOR_PIPE_IS_BROKEN
2544 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2545 /* This loses the possibility to detect the bof
2546 * situation on perl -P when the libc5 is being used.
2547 * Workaround? Maybe attach some extra state to PL_rsfp?
2550 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2552 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2555 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2556 s = swallow_bom((U8*)s);
2560 /* Incest with pod. */
2561 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2562 sv_setpv(PL_linestr, "");
2563 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2564 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2565 PL_last_lop = PL_last_uni = Nullch;
2566 PL_doextract = FALSE;
2570 } while (PL_doextract);
2571 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2572 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2573 SV *sv = NEWSV(85,0);
2575 sv_upgrade(sv, SVt_PVMG);
2576 sv_setsv(sv,PL_linestr);
2579 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2581 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2582 PL_last_lop = PL_last_uni = Nullch;
2583 if (CopLINE(PL_curcop) == 1) {
2584 while (s < PL_bufend && isSPACE(*s))
2586 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2590 if (*s == '#' && *(s+1) == '!')
2592 #ifdef ALTERNATE_SHEBANG
2594 static char as[] = ALTERNATE_SHEBANG;
2595 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2596 d = s + (sizeof(as) - 1);
2598 #endif /* ALTERNATE_SHEBANG */
2607 while (*d && !isSPACE(*d))
2611 #ifdef ARG_ZERO_IS_SCRIPT
2612 if (ipathend > ipath) {
2614 * HP-UX (at least) sets argv[0] to the script name,
2615 * which makes $^X incorrect. And Digital UNIX and Linux,
2616 * at least, set argv[0] to the basename of the Perl
2617 * interpreter. So, having found "#!", we'll set it right.
2619 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2620 assert(SvPOK(x) || SvGMAGICAL(x));
2621 if (sv_eq(x, CopFILESV(PL_curcop))) {
2622 sv_setpvn(x, ipath, ipathend - ipath);
2628 char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2629 char *lstart = SvPV(x,llen);
2631 bstart += blen - llen;
2632 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2633 sv_setpvn(x, ipath, ipathend - ipath);
2638 TAINT_NOT; /* $^X is always tainted, but that's OK */
2640 #endif /* ARG_ZERO_IS_SCRIPT */
2645 d = instr(s,"perl -");
2647 d = instr(s,"perl");
2649 /* avoid getting into infinite loops when shebang
2650 * line contains "Perl" rather than "perl" */
2652 for (d = ipathend-4; d >= ipath; --d) {
2653 if ((*d == 'p' || *d == 'P')
2654 && !ibcmp(d, "perl", 4))
2664 #ifdef ALTERNATE_SHEBANG
2666 * If the ALTERNATE_SHEBANG on this system starts with a
2667 * character that can be part of a Perl expression, then if
2668 * we see it but not "perl", we're probably looking at the
2669 * start of Perl code, not a request to hand off to some
2670 * other interpreter. Similarly, if "perl" is there, but
2671 * not in the first 'word' of the line, we assume the line
2672 * contains the start of the Perl program.
2674 if (d && *s != '#') {
2676 while (*c && !strchr("; \t\r\n\f\v#", *c))
2679 d = Nullch; /* "perl" not in first word; ignore */
2681 *s = '#'; /* Don't try to parse shebang line */
2683 #endif /* ALTERNATE_SHEBANG */
2684 #ifndef MACOS_TRADITIONAL
2689 !instr(s,"indir") &&
2690 instr(PL_origargv[0],"perl"))
2696 while (s < PL_bufend && isSPACE(*s))
2698 if (s < PL_bufend) {
2699 Newz(899,newargv,PL_origargc+3,char*);
2701 while (s < PL_bufend && !isSPACE(*s))
2704 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2707 newargv = PL_origargv;
2710 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2712 Perl_croak(aTHX_ "Can't exec %s", ipath);
2716 U32 oldpdb = PL_perldb;
2717 bool oldn = PL_minus_n;
2718 bool oldp = PL_minus_p;
2720 while (*d && !isSPACE(*d)) d++;
2721 while (SPACE_OR_TAB(*d)) d++;
2724 bool switches_done = PL_doswitches;
2726 if (*d == 'M' || *d == 'm') {
2728 while (*d && !isSPACE(*d)) d++;
2729 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2732 d = moreswitches(d);
2734 if (PL_doswitches && !switches_done) {
2735 int argc = PL_origargc;
2736 char **argv = PL_origargv;
2739 } while (argc && argv[0][0] == '-' && argv[0][1]);
2740 init_argv_symbols(argc,argv);
2742 if ((PERLDB_LINE && !oldpdb) ||
2743 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2744 /* if we have already added "LINE: while (<>) {",
2745 we must not do it again */
2747 sv_setpv(PL_linestr, "");
2748 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2749 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2750 PL_last_lop = PL_last_uni = Nullch;
2751 PL_preambled = FALSE;
2753 (void)gv_fetchfile(PL_origfilename);
2756 if (PL_doswitches && !switches_done) {
2757 int argc = PL_origargc;
2758 char **argv = PL_origargv;
2761 } while (argc && argv[0][0] == '-' && argv[0][1]);
2762 init_argv_symbols(argc,argv);
2768 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2770 PL_lex_state = LEX_FORMLINE;
2775 #ifdef PERL_STRICT_CR
2776 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2778 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2780 case ' ': case '\t': case '\f': case 013:
2781 #ifdef MACOS_TRADITIONAL
2788 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2789 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2790 /* handle eval qq[#line 1 "foo"\n ...] */
2791 CopLINE_dec(PL_curcop);
2795 while (s < d && *s != '\n')
2799 else if (s > d) /* Found by Ilya: feed random input to Perl. */
2800 Perl_croak(aTHX_ "panic: input overflow");
2802 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2804 PL_lex_state = LEX_FORMLINE;
2814 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2821 while (s < PL_bufend && SPACE_OR_TAB(*s))
2824 if (strnEQ(s,"=>",2)) {
2825 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2826 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2827 "### Saw unary minus before =>, forcing word '%s'\n", s);
2829 OPERATOR('-'); /* unary minus */
2831 PL_last_uni = PL_oldbufptr;
2833 case 'r': ftst = OP_FTEREAD; break;
2834 case 'w': ftst = OP_FTEWRITE; break;
2835 case 'x': ftst = OP_FTEEXEC; break;
2836 case 'o': ftst = OP_FTEOWNED; break;
2837 case 'R': ftst = OP_FTRREAD; break;
2838 case 'W': ftst = OP_FTRWRITE; break;
2839 case 'X': ftst = OP_FTREXEC; break;
2840 case 'O': ftst = OP_FTROWNED; break;
2841 case 'e': ftst = OP_FTIS; break;
2842 case 'z': ftst = OP_FTZERO; break;
2843 case 's': ftst = OP_FTSIZE; break;
2844 case 'f': ftst = OP_FTFILE; break;
2845 case 'd': ftst = OP_FTDIR; break;
2846 case 'l': ftst = OP_FTLINK; break;
2847 case 'p': ftst = OP_FTPIPE; break;
2848 case 'S': ftst = OP_FTSOCK; break;
2849 case 'u': ftst = OP_FTSUID; break;
2850 case 'g': ftst = OP_FTSGID; break;
2851 case 'k': ftst = OP_FTSVTX; break;
2852 case 'b': ftst = OP_FTBLK; break;
2853 case 'c': ftst = OP_FTCHR; break;
2854 case 't': ftst = OP_FTTTY; break;
2855 case 'T': ftst = OP_FTTEXT; break;
2856 case 'B': ftst = OP_FTBINARY; break;
2857 case 'M': case 'A': case 'C':
2858 gv_fetchpv("\024",TRUE, SVt_PV);
2860 case 'M': ftst = OP_FTMTIME; break;
2861 case 'A': ftst = OP_FTATIME; break;
2862 case 'C': ftst = OP_FTCTIME; break;
2870 PL_last_lop_op = (OPCODE)ftst;
2871 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2872 "### Saw file test %c\n", (int)ftst);
2877 /* Assume it was a minus followed by a one-letter named
2878 * subroutine call (or a -bareword), then. */
2879 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2880 "### %c looked like a file test but was not\n",
2889 if (PL_expect == XOPERATOR)
2894 else if (*s == '>') {
2897 if (isIDFIRST_lazy_if(s,UTF)) {
2898 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2906 if (PL_expect == XOPERATOR)
2909 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2911 OPERATOR('-'); /* unary minus */
2918 if (PL_expect == XOPERATOR)
2923 if (PL_expect == XOPERATOR)
2926 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2932 if (PL_expect != XOPERATOR) {
2933 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2934 PL_expect = XOPERATOR;
2935 force_ident(PL_tokenbuf, '*');
2948 if (PL_expect == XOPERATOR) {
2952 PL_tokenbuf[0] = '%';
2953 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2954 if (!PL_tokenbuf[1]) {
2957 PL_pending_ident = '%';
2976 switch (PL_expect) {
2979 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2981 PL_bufptr = s; /* update in case we back off */
2987 PL_expect = XTERMBLOCK;
2991 while (isIDFIRST_lazy_if(s,UTF)) {
2992 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2993 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2994 if (tmp < 0) tmp = -tmp;
3010 d = scan_str(d,TRUE,TRUE);
3012 /* MUST advance bufptr here to avoid bogus
3013 "at end of line" context messages from yyerror().
3015 PL_bufptr = s + len;
3016 yyerror("Unterminated attribute parameter in attribute list");
3019 return 0; /* EOF indicator */
3023 SV *sv = newSVpvn(s, len);
3024 sv_catsv(sv, PL_lex_stuff);
3025 attrs = append_elem(OP_LIST, attrs,
3026 newSVOP(OP_CONST, 0, sv));
3027 SvREFCNT_dec(PL_lex_stuff);
3028 PL_lex_stuff = Nullsv;
3031 /* NOTE: any CV attrs applied here need to be part of
3032 the CVf_BUILTIN_ATTRS define in cv.h! */
3033 if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3034 CvLVALUE_on(PL_compcv);
3035 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3036 CvLOCKED_on(PL_compcv);
3037 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3038 CvMETHOD_on(PL_compcv);
3039 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3040 CvASSERTION_on(PL_compcv);
3042 else if (PL_in_my == KEY_our && len == 6 &&
3043 strnEQ(s, "unique", len))
3044 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3046 /* After we've set the flags, it could be argued that
3047 we don't need to do the attributes.pm-based setting
3048 process, and shouldn't bother appending recognized
3049 flags. To experiment with that, uncomment the
3050 following "else". (Note that's already been
3051 uncommented. That keeps the above-applied built-in
3052 attributes from being intercepted (and possibly
3053 rejected) by a package's attribute routines, but is
3054 justified by the performance win for the common case
3055 of applying only built-in attributes.) */
3057 attrs = append_elem(OP_LIST, attrs,
3058 newSVOP(OP_CONST, 0,
3062 if (*s == ':' && s[1] != ':')
3065 break; /* require real whitespace or :'s */
3067 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3068 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3069 char q = ((*s == '\'') ? '"' : '\'');
3070 /* If here for an expression, and parsed no attrs, back off. */
3071 if (tmp == '=' && !attrs) {
3075 /* MUST advance bufptr here to avoid bogus "at end of line"
3076 context messages from yyerror().
3080 yyerror("Unterminated attribute list");
3082 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3090 PL_nextval[PL_nexttoke].opval = attrs;
3098 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3099 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3116 if (PL_lex_brackets <= 0)
3117 yyerror("Unmatched right square bracket");
3120 if (PL_lex_state == LEX_INTERPNORMAL) {
3121 if (PL_lex_brackets == 0) {
3122 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3123 PL_lex_state = LEX_INTERPEND;
3130 if (PL_lex_brackets > 100) {
3131 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3133 switch (PL_expect) {
3135 if (PL_lex_formbrack) {
3139 if (PL_oldoldbufptr == PL_last_lop)
3140 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3142 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3143 OPERATOR(HASHBRACK);
3145 while (s < PL_bufend && SPACE_OR_TAB(*s))
3148 PL_tokenbuf[0] = '\0';
3149 if (d < PL_bufend && *d == '-') {
3150 PL_tokenbuf[0] = '-';
3152 while (d < PL_bufend && SPACE_OR_TAB(*d))
3155 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3156 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3158 while (d < PL_bufend && SPACE_OR_TAB(*d))
3161 char minus = (PL_tokenbuf[0] == '-');
3162 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3170 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3175 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3180 if (PL_oldoldbufptr == PL_last_lop)
3181 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3183 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3186 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3188 /* This hack is to get the ${} in the message. */
3190 yyerror("syntax error");
3193 OPERATOR(HASHBRACK);
3195 /* This hack serves to disambiguate a pair of curlies
3196 * as being a block or an anon hash. Normally, expectation
3197 * determines that, but in cases where we're not in a
3198 * position to expect anything in particular (like inside
3199 * eval"") we have to resolve the ambiguity. This code
3200 * covers the case where the first term in the curlies is a
3201 * quoted string. Most other cases need to be explicitly
3202 * disambiguated by prepending a `+' before the opening
3203 * curly in order to force resolution as an anon hash.
3205 * XXX should probably propagate the outer expectation
3206 * into eval"" to rely less on this hack, but that could
3207 * potentially break current behavior of eval"".
3211 if (*s == '\'' || *s == '"' || *s == '`') {
3212 /* common case: get past first string, handling escapes */
3213 for (t++; t < PL_bufend && *t != *s;)
3214 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3218 else if (*s == 'q') {
3221 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3224 /* skip q//-like construct */
3226 char open, close, term;
3229 while (t < PL_bufend && isSPACE(*t))
3231 /* check for q => */
3232 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3233 OPERATOR(HASHBRACK);
3237 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3241 for (t++; t < PL_bufend; t++) {
3242 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3244 else if (*t == open)
3248 for (t++; t < PL_bufend; t++) {
3249 if (*t == '\\' && t+1 < PL_bufend)
3251 else if (*t == close && --brackets <= 0)
3253 else if (*t == open)
3260 /* skip plain q word */
3261 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3264 else if (isALNUM_lazy_if(t,UTF)) {
3266 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3269 while (t < PL_bufend && isSPACE(*t))
3271 /* if comma follows first term, call it an anon hash */
3272 /* XXX it could be a comma expression with loop modifiers */
3273 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3274 || (*t == '=' && t[1] == '>')))
3275 OPERATOR(HASHBRACK);
3276 if (PL_expect == XREF)
3279 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3285 yylval.ival = CopLINE(PL_curcop);
3286 if (isSPACE(*s) || *s == '#')
3287 PL_copline = NOLINE; /* invalidate current command line number */
3292 if (PL_lex_brackets <= 0)
3293 yyerror("Unmatched right curly bracket");
3295 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3296 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3297 PL_lex_formbrack = 0;
3298 if (PL_lex_state == LEX_INTERPNORMAL) {
3299 if (PL_lex_brackets == 0) {
3300 if (PL_expect & XFAKEBRACK) {
3301 PL_expect &= XENUMMASK;
3302 PL_lex_state = LEX_INTERPEND;
3304 return yylex(); /* ignore fake brackets */
3306 if (*s == '-' && s[1] == '>')
3307 PL_lex_state = LEX_INTERPENDMAYBE;
3308 else if (*s != '[' && *s != '{')
3309 PL_lex_state = LEX_INTERPEND;
3312 if (PL_expect & XFAKEBRACK) {
3313 PL_expect &= XENUMMASK;
3315 return yylex(); /* ignore fake brackets */
3325 if (PL_expect == XOPERATOR) {
3326 if (ckWARN(WARN_SEMICOLON)
3327 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3329 CopLINE_dec(PL_curcop);
3330 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3331 CopLINE_inc(PL_curcop);
3336 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3338 PL_expect = XOPERATOR;
3339 force_ident(PL_tokenbuf, '&');
3343 yylval.ival = (OPpENTERSUB_AMPER<<8);
3362 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3363 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3365 if (PL_expect == XSTATE && isALPHA(tmp) &&
3366 (s == PL_linestart+1 || s[-2] == '\n') )
3368 if (PL_in_eval && !PL_rsfp) {
3373 if (strnEQ(s,"=cut",4)) {
3387 PL_doextract = TRUE;
3390 if (PL_lex_brackets < PL_lex_formbrack) {
3392 #ifdef PERL_STRICT_CR
3393 for (t = s; SPACE_OR_TAB(*t); t++) ;
3395 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3397 if (*t == '\n' || *t == '#') {
3415 if (PL_expect != XOPERATOR) {
3416 if (s[1] != '<' && !strchr(s,'>'))
3419 s = scan_heredoc(s);
3421 s = scan_inputsymbol(s);
3422 TERM(sublex_start());
3427 SHop(OP_LEFT_SHIFT);
3441 SHop(OP_RIGHT_SHIFT);
3450 if (PL_expect == XOPERATOR) {
3451 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3454 return ','; /* grandfather non-comma-format format */
3458 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3459 PL_tokenbuf[0] = '@';
3460 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3461 sizeof PL_tokenbuf - 1, FALSE);
3462 if (PL_expect == XOPERATOR)
3463 no_op("Array length", s);
3464 if (!PL_tokenbuf[1])
3466 PL_expect = XOPERATOR;
3467 PL_pending_ident = '#';
3471 PL_tokenbuf[0] = '$';
3472 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3473 sizeof PL_tokenbuf - 1, FALSE);
3474 if (PL_expect == XOPERATOR)
3476 if (!PL_tokenbuf[1]) {
3478 yyerror("Final $ should be \\$ or $name");
3482 /* This kludge not intended to be bulletproof. */
3483 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3484 yylval.opval = newSVOP(OP_CONST, 0,
3485 newSViv(PL_compiling.cop_arybase));
3486 yylval.opval->op_private = OPpCONST_ARYBASE;
3492 if (PL_lex_state == LEX_NORMAL)
3495 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3498 PL_tokenbuf[0] = '@';
3499 if (ckWARN(WARN_SYNTAX)) {
3501 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3504 PL_bufptr = skipspace(PL_bufptr);
3505 while (t < PL_bufend && *t != ']')
3507 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3508 "Multidimensional syntax %.*s not supported",
3509 (t - PL_bufptr) + 1, PL_bufptr);
3513 else if (*s == '{') {
3514 PL_tokenbuf[0] = '%';
3515 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3516 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3518 char tmpbuf[sizeof PL_tokenbuf];
3520 for (t++; isSPACE(*t); t++) ;
3521 if (isIDFIRST_lazy_if(t,UTF)) {
3522 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3523 for (; isSPACE(*t); t++) ;
3524 if (*t == ';' && get_cv(tmpbuf, FALSE))
3525 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3526 "You need to quote \"%s\"", tmpbuf);
3532 PL_expect = XOPERATOR;
3533 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3534 bool islop = (PL_last_lop == PL_oldoldbufptr);
3535 if (!islop || PL_last_lop_op == OP_GREPSTART)
3536 PL_expect = XOPERATOR;
3537 else if (strchr("$@\"'`q", *s))
3538 PL_expect = XTERM; /* e.g. print $fh "foo" */
3539 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3540 PL_expect = XTERM; /* e.g. print $fh &sub */
3541 else if (isIDFIRST_lazy_if(s,UTF)) {
3542 char tmpbuf[sizeof PL_tokenbuf];
3543 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3544 if ((tmp = keyword(tmpbuf, len))) {
3545 /* binary operators exclude handle interpretations */
3557 PL_expect = XTERM; /* e.g. print $fh length() */
3562 GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3563 if (gv && GvCVu(gv))
3564 PL_expect = XTERM; /* e.g. print $fh subr() */
3567 else if (isDIGIT(*s))
3568 PL_expect = XTERM; /* e.g. print $fh 3 */
3569 else if (*s == '.' && isDIGIT(s[1]))
3570 PL_expect = XTERM; /* e.g. print $fh .3 */
3571 else if (strchr("?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3572 PL_expect = XTERM; /* e.g. print $fh -1 */
3573 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3574 PL_expect = XTERM; /* e.g. print $fh /.../
3575 XXX except DORDOR operator */
3576 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3577 PL_expect = XTERM; /* print $fh <<"EOF" */
3579 PL_pending_ident = '$';
3583 if (PL_expect == XOPERATOR)
3585 PL_tokenbuf[0] = '@';
3586 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3587 if (!PL_tokenbuf[1]) {
3590 if (PL_lex_state == LEX_NORMAL)
3592 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3594 PL_tokenbuf[0] = '%';
3596 /* Warn about @ where they meant $. */
3597 if (ckWARN(WARN_SYNTAX)) {
3598 if (*s == '[' || *s == '{') {
3600 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3602 if (*t == '}' || *t == ']') {
3604 PL_bufptr = skipspace(PL_bufptr);
3605 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3606 "Scalar value %.*s better written as $%.*s",
3607 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3612 PL_pending_ident = '@';
3615 case '/': /* may be division, defined-or, or pattern */
3616 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3620 case '?': /* may either be conditional or pattern */
3621 if(PL_expect == XOPERATOR) {
3629 /* A // operator. */
3639 /* Disable warning on "study /blah/" */
3640 if (PL_oldoldbufptr == PL_last_uni
3641 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3642 || memNE(PL_last_uni, "study", 5)
3643 || isALNUM_lazy_if(PL_last_uni+5,UTF)
3646 s = scan_pat(s,OP_MATCH);
3647 TERM(sublex_start());
3651 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3652 #ifdef PERL_STRICT_CR
3655 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3657 && (s == PL_linestart || s[-1] == '\n') )
3659 PL_lex_formbrack = 0;
3663 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3669 yylval.ival = OPf_SPECIAL;
3675 if (PL_expect != XOPERATOR)
3680 case '0': case '1': case '2': case '3': case '4':
3681 case '5': case '6': case '7': case '8': case '9':
3682 s = scan_num(s, &yylval);
3683 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3684 "### Saw number in '%s'\n", s);
3686 if (PL_expect == XOPERATOR)
3691 s = scan_str(s,FALSE,FALSE);
3692 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3693 "### Saw string before '%s'\n", s);
3695 if (PL_expect == XOPERATOR) {
3696 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3699 return ','; /* grandfather non-comma-format format */
3705 missingterm((char*)0);
3706 yylval.ival = OP_CONST;
3707 TERM(sublex_start());
3710 s = scan_str(s,FALSE,FALSE);
3711 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3712 "### Saw string before '%s'\n", s);
3714 if (PL_expect == XOPERATOR) {
3715 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3718 return ','; /* grandfather non-comma-format format */
3724 missingterm((char*)0);
3725 yylval.ival = OP_CONST;
3726 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3727 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3728 yylval.ival = OP_STRINGIFY;
3732 TERM(sublex_start());
3735 s = scan_str(s,FALSE,FALSE);
3736 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3737 "### Saw backtick string before '%s'\n", s);
3739 if (PL_expect == XOPERATOR)
3740 no_op("Backticks",s);
3742 missingterm((char*)0);
3743 yylval.ival = OP_BACKTICK;
3745 TERM(sublex_start());
3749 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3750 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3752 if (PL_expect == XOPERATOR)
3753 no_op("Backslash",s);
3757 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3761 while (isDIGIT(*start) || *start == '_')
3763 if (*start == '.' && isDIGIT(start[1])) {
3764 s = scan_num(s, &yylval);
3767 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3768 else if (!isALPHA(*start) && (PL_expect == XTERM
3769 || PL_expect == XREF || PL_expect == XSTATE
3770 || PL_expect == XTERMORDORDOR)) {
3774 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3777 s = scan_num(s, &yylval);
3784 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3824 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3826 /* Some keywords can be followed by any delimiter, including ':' */
3827 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3828 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3829 (PL_tokenbuf[0] == 'q' &&
3830 strchr("qwxr", PL_tokenbuf[1])))));
3832 /* x::* is just a word, unless x is "CORE" */
3833 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3837 while (d < PL_bufend && isSPACE(*d))
3838 d++; /* no comments skipped here, or s### is misparsed */
3840 /* Is this a label? */
3841 if (!tmp && PL_expect == XSTATE
3842 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3844 yylval.pval = savepv(PL_tokenbuf);
3849 /* Check for keywords */
3850 tmp = keyword(PL_tokenbuf, len);
3852 /* Is this a word before a => operator? */
3853 if (*d == '=' && d[1] == '>') {
3855 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3856 yylval.opval->op_private = OPpCONST_BARE;
3857 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3858 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3862 if (tmp < 0) { /* second-class keyword? */
3863 GV *ogv = Nullgv; /* override (winner) */
3864 GV *hgv = Nullgv; /* hidden (loser) */
3865 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3867 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3870 if (GvIMPORTED_CV(gv))
3872 else if (! CvMETHOD(cv))
3876 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3877 (gv = *gvp) != (GV*)&PL_sv_undef &&
3878 GvCVu(gv) && GvIMPORTED_CV(gv))
3885 tmp = 0; /* overridden by import or by GLOBAL */
3888 && -tmp==KEY_lock /* XXX generalizable kludge */
3890 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3892 tmp = 0; /* any sub overrides "weak" keyword */
3894 else { /* no override */
3896 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3897 Perl_warner(aTHX_ packWARN(WARN_MISC),
3898 "dump() better written as CORE::dump()");
3902 if (ckWARN(WARN_AMBIGUOUS) && hgv
3903 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3904 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3905 "Ambiguous call resolved as CORE::%s(), %s",
3906 GvENAME(hgv), "qualify as such or use &");
3913 default: /* not a keyword */
3917 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3919 /* Get the rest if it looks like a package qualifier */
3921 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3923 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3926 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3927 *s == '\'' ? "'" : "::");
3932 if (PL_expect == XOPERATOR) {
3933 if (PL_bufptr == PL_linestart) {
3934 CopLINE_dec(PL_curcop);
3935 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3936 CopLINE_inc(PL_curcop);
3939 no_op("Bareword",s);
3942 /* Look for a subroutine with this name in current package,
3943 unless name is "Foo::", in which case Foo is a bearword
3944 (and a package name). */
3947 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3949 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3950 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
3951 "Bareword \"%s\" refers to nonexistent package",
3954 PL_tokenbuf[len] = '\0';
3961 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3964 /* if we saw a global override before, get the right name */
3967 sv = newSVpvn("CORE::GLOBAL::",14);
3968 sv_catpv(sv,PL_tokenbuf);
3971 sv = newSVpv(PL_tokenbuf,0);
3973 /* Presume this is going to be a bareword of some sort. */
3976 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3977 yylval.opval->op_private = OPpCONST_BARE;
3978 /* UTF-8 package name? */
3979 if (UTF && !IN_BYTES &&
3980 is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
3983 /* And if "Foo::", then that's what it certainly is. */
3988 /* See if it's the indirect object for a list operator. */
3990 if (PL_oldoldbufptr &&
3991 PL_oldoldbufptr < PL_bufptr &&
3992 (PL_oldoldbufptr == PL_last_lop
3993 || PL_oldoldbufptr == PL_last_uni) &&
3994 /* NO SKIPSPACE BEFORE HERE! */
3995 (PL_expect == XREF ||
3996 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3998 bool immediate_paren = *s == '(';
4000 /* (Now we can afford to cross potential line boundary.) */
4003 /* Two barewords in a row may indicate method call. */
4005 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4008 /* If not a declared subroutine, it's an indirect object. */
4009 /* (But it's an indir obj regardless for sort.) */
4011 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4012 ((!gv || !GvCVu(gv)) &&
4013 (PL_last_lop_op != OP_MAPSTART &&
4014 PL_last_lop_op != OP_GREPSTART))))
4016 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4021 PL_expect = XOPERATOR;
4024 /* Is this a word before a => operator? */
4025 if (*s == '=' && s[1] == '>' && !pkgname) {
4027 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4028 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4029 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4033 /* If followed by a paren, it's certainly a subroutine. */
4036 if (gv && GvCVu(gv)) {
4037 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4038 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4043 PL_nextval[PL_nexttoke].opval = yylval.opval;
4044 PL_expect = XOPERATOR;
4050 /* If followed by var or block, call it a method (unless sub) */
4052 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4053 PL_last_lop = PL_oldbufptr;
4054 PL_last_lop_op = OP_METHOD;
4058 /* If followed by a bareword, see if it looks like indir obj. */
4061 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4062 && (tmp = intuit_method(s,gv)))
4065 /* Not a method, so call it a subroutine (if defined) */
4067 if (gv && GvCVu(gv)) {
4069 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4070 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4071 "Ambiguous use of -%s resolved as -&%s()",
4072 PL_tokenbuf, PL_tokenbuf);
4073 /* Check for a constant sub */
4075 if ((sv = cv_const_sv(cv))) {
4077 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4078 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4079 yylval.opval->op_private = 0;
4083 /* Resolve to GV now. */
4084 op_free(yylval.opval);
4085 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4086 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4087 PL_last_lop = PL_oldbufptr;
4088 PL_last_lop_op = OP_ENTERSUB;
4089 /* Is there a prototype? */
4092 char *proto = SvPV((SV*)cv, len);
4095 if (strEQ(proto, "$"))
4097 while (*proto == ';')
4099 if (*proto == '&' && *s == '{') {
4100 sv_setpv(PL_subname, PL_curstash ?
4101 "__ANON__" : "__ANON__::__ANON__");
4105 PL_nextval[PL_nexttoke].opval = yylval.opval;
4111 /* Call it a bare word */
4113 if (PL_hints & HINT_STRICT_SUBS)
4114 yylval.opval->op_private |= OPpCONST_STRICT;
4117 if (ckWARN(WARN_RESERVED)) {
4118 if (lastchar != '-') {
4119 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4120 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4121 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4128 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4129 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4130 "Operator or semicolon missing before %c%s",
4131 lastchar, PL_tokenbuf);
4132 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4133 "Ambiguous use of %c resolved as operator %c",
4134 lastchar, lastchar);
4140 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4141 newSVpv(CopFILE(PL_curcop),0));
4145 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4146 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4149 case KEY___PACKAGE__:
4150 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4152 ? newSVsv(PL_curstname)
4161 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4162 char *pname = "main";
4163 if (PL_tokenbuf[2] == 'D')
4164 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4165 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4168 GvIOp(gv) = newIO();
4169 IoIFP(GvIOp(gv)) = PL_rsfp;
4170 #if defined(HAS_FCNTL) && defined(F_SETFD)
4172 int fd = PerlIO_fileno(PL_rsfp);
4173 fcntl(fd,F_SETFD,fd >= 3);
4176 /* Mark this internal pseudo-handle as clean */
4177 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4179 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4180 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4181 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4183 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4184 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4185 /* if the script was opened in binmode, we need to revert
4186 * it to text mode for compatibility; but only iff it has CRs
4187 * XXX this is a questionable hack at best. */
4188 if (PL_bufend-PL_bufptr > 2
4189 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4192 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4193 loc = PerlIO_tell(PL_rsfp);
4194 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4197 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4199 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4200 #endif /* NETWARE */
4201 #ifdef PERLIO_IS_STDIO /* really? */
4202 # if defined(__BORLANDC__)
4203 /* XXX see note in do_binmode() */
4204 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4208 PerlIO_seek(PL_rsfp, loc, 0);
4212 #ifdef PERLIO_LAYERS
4215 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4216 else if (PL_encoding) {
4223 XPUSHs(PL_encoding);
4225 call_method("name", G_SCALAR);
4229 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4230 Perl_form(aTHX_ ":encoding(%"SVf")",
4248 if (PL_expect == XSTATE) {
4255 if (*s == ':' && s[1] == ':') {
4258 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4259 if (!(tmp = keyword(PL_tokenbuf, len)))
4260 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4274 LOP(OP_ACCEPT,XTERM);
4280 LOP(OP_ATAN2,XTERM);
4286 LOP(OP_BINMODE,XTERM);
4289 LOP(OP_BLESS,XTERM);
4298 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4315 if (!PL_cryptseen) {
4316 PL_cryptseen = TRUE;
4320 LOP(OP_CRYPT,XTERM);
4323 LOP(OP_CHMOD,XTERM);
4326 LOP(OP_CHOWN,XTERM);
4329 LOP(OP_CONNECT,XTERM);
4345 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4349 PL_hints |= HINT_BLOCK_SCOPE;
4359 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4360 LOP(OP_DBMOPEN,XTERM);
4366 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4373 yylval.ival = CopLINE(PL_curcop);
4387 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4388 UNIBRACK(OP_ENTEREVAL);
4406 case KEY_endhostent:
4412 case KEY_endservent:
4415 case KEY_endprotoent:
4426 yylval.ival = CopLINE(PL_curcop);
4428 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4430 if ((PL_bufend - p) >= 3 &&
4431 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4433 else if ((PL_bufend - p) >= 4 &&
4434 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4437 if (isIDFIRST_lazy_if(p,UTF)) {
4438 p = scan_ident(p, PL_bufend,
4439 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4443 Perl_croak(aTHX_ "Missing $ on loop variable");
4448 LOP(OP_FORMLINE,XTERM);
4454 LOP(OP_FCNTL,XTERM);
4460 LOP(OP_FLOCK,XTERM);
4469 LOP(OP_GREPSTART, XREF);
4472 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4487 case KEY_getpriority:
4488 LOP(OP_GETPRIORITY,XTERM);
4490 case KEY_getprotobyname:
4493 case KEY_getprotobynumber:
4494 LOP(OP_GPBYNUMBER,XTERM);
4496 case KEY_getprotoent:
4508 case KEY_getpeername:
4509 UNI(OP_GETPEERNAME);
4511 case KEY_gethostbyname:
4514 case KEY_gethostbyaddr:
4515 LOP(OP_GHBYADDR,XTERM);
4517 case KEY_gethostent:
4520 case KEY_getnetbyname:
4523 case KEY_getnetbyaddr:
4524 LOP(OP_GNBYADDR,XTERM);
4529 case KEY_getservbyname:
4530 LOP(OP_GSBYNAME,XTERM);
4532 case KEY_getservbyport:
4533 LOP(OP_GSBYPORT,XTERM);
4535 case KEY_getservent:
4538 case KEY_getsockname:
4539 UNI(OP_GETSOCKNAME);
4541 case KEY_getsockopt:
4542 LOP(OP_GSOCKOPT,XTERM);
4564 yylval.ival = CopLINE(PL_curcop);
4568 LOP(OP_INDEX,XTERM);
4574 LOP(OP_IOCTL,XTERM);
4586 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4618 LOP(OP_LISTEN,XTERM);
4627 s = scan_pat(s,OP_MATCH);
4628 TERM(sublex_start());
4631 LOP(OP_MAPSTART, XREF);
4634 LOP(OP_MKDIR,XTERM);
4637 LOP(OP_MSGCTL,XTERM);
4640 LOP(OP_MSGGET,XTERM);
4643 LOP(OP_MSGRCV,XTERM);
4646 LOP(OP_MSGSND,XTERM);
4652 if (isIDFIRST_lazy_if(s,UTF)) {
4653 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4654 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4656 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4657 if (!PL_in_my_stash) {
4660 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4668 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4675 if (PL_expect != XSTATE)
4676 yyerror("\"no\" not allowed in expression");
4677 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4678 s = force_version(s, FALSE);
4683 if (*s == '(' || (s = skipspace(s), *s == '('))
4690 if (isIDFIRST_lazy_if(s,UTF)) {
4692 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4694 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4696 && !(t[0] == '=' && t[1] == '>')
4698 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4699 "Precedence problem: open %.*s should be open(%.*s)",
4700 d - s, s, d - s, s);
4706 yylval.ival = OP_OR;
4716 LOP(OP_OPEN_DIR,XTERM);
4719 checkcomma(s,PL_tokenbuf,"filehandle");
4723 checkcomma(s,PL_tokenbuf,"filehandle");
4742 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4746 LOP(OP_PIPE_OP,XTERM);
4749 s = scan_str(s,FALSE,FALSE);
4751 missingterm((char*)0);
4752 yylval.ival = OP_CONST;
4753 TERM(sublex_start());
4759 s = scan_str(s,FALSE,FALSE);
4761 missingterm((char*)0);
4763 if (SvCUR(PL_lex_stuff)) {
4766 d = SvPV_force(PL_lex_stuff, len);
4769 for (; isSPACE(*d) && len; --len, ++d) ;
4772 if (!warned && ckWARN(WARN_QW)) {
4773 for (; !isSPACE(*d) && len; --len, ++d) {
4775 Perl_warner(aTHX_ packWARN(WARN_QW),
4776 "Possible attempt to separate words with commas");
4779 else if (*d == '#') {
4780 Perl_warner(aTHX_ packWARN(WARN_QW),
4781 "Possible attempt to put comments in qw() list");
4787 for (; !isSPACE(*d) && len; --len, ++d) ;
4789 sv = newSVpvn(b, d-b);
4790 if (DO_UTF8(PL_lex_stuff))
4792 words = append_elem(OP_LIST, words,
4793 newSVOP(OP_CONST, 0, tokeq(sv)));
4797 PL_nextval[PL_nexttoke].opval = words;
4802 SvREFCNT_dec(PL_lex_stuff);
4803 PL_lex_stuff = Nullsv;
4809 s = scan_str(s,FALSE,FALSE);
4811 missingterm((char*)0);
4812 yylval.ival = OP_STRINGIFY;
4813 if (SvIVX(PL_lex_stuff) == '\'')
4814 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4815 TERM(sublex_start());
4818 s = scan_pat(s,OP_QR);
4819 TERM(sublex_start());
4822 s = scan_str(s,FALSE,FALSE);
4824 missingterm((char*)0);
4825 yylval.ival = OP_BACKTICK;
4827 TERM(sublex_start());
4835 s = force_version(s, FALSE);
4837 else if (*s != 'v' || !isDIGIT(s[1])
4838 || (s = force_version(s, TRUE), *s == 'v'))
4840 *PL_tokenbuf = '\0';
4841 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4842 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4843 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4845 yyerror("<> should be quotes");
4853 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4857 LOP(OP_RENAME,XTERM);
4866 LOP(OP_RINDEX,XTERM);
4876 UNIDOR(OP_READLINE);
4889 LOP(OP_REVERSE,XTERM);
4892 UNIDOR(OP_READLINK);
4900 TERM(sublex_start());
4902 TOKEN(1); /* force error */
4911 LOP(OP_SELECT,XTERM);
4917 LOP(OP_SEMCTL,XTERM);
4920 LOP(OP_SEMGET,XTERM);
4923 LOP(OP_SEMOP,XTERM);
4929 LOP(OP_SETPGRP,XTERM);
4931 case KEY_setpriority:
4932 LOP(OP_SETPRIORITY,XTERM);
4934 case KEY_sethostent:
4940 case KEY_setservent:
4943 case KEY_setprotoent:
4953 LOP(OP_SEEKDIR,XTERM);
4955 case KEY_setsockopt:
4956 LOP(OP_SSOCKOPT,XTERM);
4962 LOP(OP_SHMCTL,XTERM);
4965 LOP(OP_SHMGET,XTERM);
4968 LOP(OP_SHMREAD,XTERM);
4971 LOP(OP_SHMWRITE,XTERM);
4974 LOP(OP_SHUTDOWN,XTERM);
4983 LOP(OP_SOCKET,XTERM);
4985 case KEY_socketpair:
4986 LOP(OP_SOCKPAIR,XTERM);
4989 checkcomma(s,PL_tokenbuf,"subroutine name");
4991 if (*s == ';' || *s == ')') /* probably a close */
4992 Perl_croak(aTHX_ "sort is now a reserved word");
4994 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4998 LOP(OP_SPLIT,XTERM);
5001 LOP(OP_SPRINTF,XTERM);
5004 LOP(OP_SPLICE,XTERM);
5019 LOP(OP_SUBSTR,XTERM);
5025 char tmpbuf[sizeof PL_tokenbuf];
5026 SSize_t tboffset = 0;
5027 expectation attrful;
5028 bool have_name, have_proto, bad_proto;
5033 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5034 (*s == ':' && s[1] == ':'))
5037 attrful = XATTRBLOCK;
5038 /* remember buffer pos'n for later force_word */
5039 tboffset = s - PL_oldbufptr;
5040 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5041 if (strchr(tmpbuf, ':'))
5042 sv_setpv(PL_subname, tmpbuf);
5044 sv_setsv(PL_subname,PL_curstname);
5045 sv_catpvn(PL_subname,"::",2);
5046 sv_catpvn(PL_subname,tmpbuf,len);
5053 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5054 PL_expect = XTERMBLOCK;
5055 attrful = XATTRTERM;
5056 sv_setpv(PL_subname,"?");
5060 if (key == KEY_format) {
5062 PL_lex_formbrack = PL_lex_brackets + 1;
5064 (void) force_word(PL_oldbufptr + tboffset, WORD,
5069 /* Look for a prototype */
5073 s = scan_str(s,FALSE,FALSE);
5075 Perl_croak(aTHX_ "Prototype not terminated");
5076 /* strip spaces and check for bad characters */
5077 d = SvPVX(PL_lex_stuff);
5080 for (p = d; *p; ++p) {
5083 if (!strchr("$@%*;[]&\\", *p))
5088 if (bad_proto && ckWARN(WARN_SYNTAX))
5089 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5090 "Illegal character in prototype for %"SVf" : %s",
5092 SvCUR(PL_lex_stuff) = tmp;
5100 if (*s == ':' && s[1] != ':')
5101 PL_expect = attrful;
5102 else if (!have_name && *s != '{' && key == KEY_sub)
5103 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5106 PL_nextval[PL_nexttoke].opval =
5107 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5108 PL_lex_stuff = Nullsv;
5112 sv_setpv(PL_subname,
5113 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5116 (void) force_word(PL_oldbufptr + tboffset, WORD,
5125 LOP(OP_SYSTEM,XREF);
5128 LOP(OP_SYMLINK,XTERM);
5131 LOP(OP_SYSCALL,XTERM);
5134 LOP(OP_SYSOPEN,XTERM);
5137 LOP(OP_SYSSEEK,XTERM);
5140 LOP(OP_SYSREAD,XTERM);
5143 LOP(OP_SYSWRITE,XTERM);
5147 TERM(sublex_start());
5168 LOP(OP_TRUNCATE,XTERM);
5180 yylval.ival = CopLINE(PL_curcop);
5184 yylval.ival = CopLINE(PL_curcop);
5188 LOP(OP_UNLINK,XTERM);
5194 LOP(OP_UNPACK,XTERM);
5197 LOP(OP_UTIME,XTERM);
5203 LOP(OP_UNSHIFT,XTERM);
5206 if (PL_expect != XSTATE)
5207 yyerror("\"use\" not allowed in expression");
5209 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5210 s = force_version(s, TRUE);
5211 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5212 PL_nextval[PL_nexttoke].opval = Nullop;
5215 else if (*s == 'v') {
5216 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5217 s = force_version(s, FALSE);
5221 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5222 s = force_version(s, FALSE);
5234 yylval.ival = CopLINE(PL_curcop);
5238 PL_hints |= HINT_BLOCK_SCOPE;
5245 LOP(OP_WAITPID,XTERM);
5254 ctl_l[0] = toCTRL('L');
5256 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5259 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5264 if (PL_expect == XOPERATOR)
5270 yylval.ival = OP_XOR;
5275 TERM(sublex_start());
5280 #pragma segment Main
5284 S_pending_ident(pTHX)
5287 register I32 tmp = 0;
5288 /* pit holds the identifier we read and pending_ident is reset */
5289 char pit = PL_pending_ident;
5290 PL_pending_ident = 0;
5292 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5293 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5295 /* if we're in a my(), we can't allow dynamics here.
5296 $foo'bar has already been turned into $foo::bar, so
5297 just check for colons.
5299 if it's a legal name, the OP is a PADANY.
5302 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5303 if (strchr(PL_tokenbuf,':'))
5304 yyerror(Perl_form(aTHX_ "No package name allowed for "
5305 "variable %s in \"our\"",
5307 tmp = allocmy(PL_tokenbuf);
5310 if (strchr(PL_tokenbuf,':'))
5311 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5313 yylval.opval = newOP(OP_PADANY, 0);
5314 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5320 build the ops for accesses to a my() variable.
5322 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5323 then used in a comparison. This catches most, but not
5324 all cases. For instance, it catches
5325 sort { my($a); $a <=> $b }
5327 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5328 (although why you'd do that is anyone's guess).
5331 if (!strchr(PL_tokenbuf,':')) {
5333 tmp = pad_findmy(PL_tokenbuf);
5334 if (tmp != NOT_IN_PAD) {
5335 /* might be an "our" variable" */
5336 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5337 /* build ops for a bareword */
5338 SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0);
5339 sv_catpvn(sym, "::", 2);
5340 sv_catpv(sym, PL_tokenbuf+1);
5341 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5342 yylval.opval->op_private = OPpCONST_ENTERED;
5343 gv_fetchpv(SvPVX(sym),
5345 ? (GV_ADDMULTI | GV_ADDINEVAL)
5348 ((PL_tokenbuf[0] == '$') ? SVt_PV
5349 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5354 /* if it's a sort block and they're naming $a or $b */
5355 if (PL_last_lop_op == OP_SORT &&
5356 PL_tokenbuf[0] == '$' &&
5357 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5360 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5361 d < PL_bufend && *d != '\n';
5364 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5365 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5371 yylval.opval = newOP(OP_PADANY, 0);
5372 yylval.opval->op_targ = tmp;
5378 Whine if they've said @foo in a doublequoted string,
5379 and @foo isn't a variable we can find in the symbol
5382 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5383 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5384 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5385 && ckWARN(WARN_AMBIGUOUS))
5387 /* Downgraded from fatal to warning 20000522 mjd */
5388 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5389 "Possible unintended interpolation of %s in string",
5394 /* build ops for a bareword */
5395 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5396 yylval.opval->op_private = OPpCONST_ENTERED;
5397 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5398 ((PL_tokenbuf[0] == '$') ? SVt_PV
5399 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5405 Perl_keyword(pTHX_ register char *d, I32 len)
5410 if (strEQ(d,"__FILE__")) return -KEY___FILE__;
5411 if (strEQ(d,"__LINE__")) return -KEY___LINE__;
5412 if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
5413 if (strEQ(d,"__DATA__")) return KEY___DATA__;
5414 if (strEQ(d,"__END__")) return KEY___END__;
5418 if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
5423 if (strEQ(d,"and")) return -KEY_and;
5424 if (strEQ(d,"abs")) return -KEY_abs;
5427 if (strEQ(d,"alarm")) return -KEY_alarm;
5428 if (strEQ(d,"atan2")) return -KEY_atan2;
5431 if (strEQ(d,"accept")) return -KEY_accept;
5436 if (strEQ(d,"BEGIN")) return KEY_BEGIN;
5439 if (strEQ(d,"bless")) return -KEY_bless;
5440 if (strEQ(d,"bind")) return -KEY_bind;
5441 if (strEQ(d,"binmode")) return -KEY_binmode;
5444 if (strEQ(d,"CORE")) return -KEY_CORE;
5445 if (strEQ(d,"CHECK")) return KEY_CHECK;
5450 if (strEQ(d,"cmp")) return -KEY_cmp;
5451 if (strEQ(d,"chr")) return -KEY_chr;
5452 if (strEQ(d,"cos")) return -KEY_cos;
5455 if (strEQ(d,"chop")) return -KEY_chop;
5458 if (strEQ(d,"close")) return -KEY_close;
5459 if (strEQ(d,"chdir")) return -KEY_chdir;
5460 if (strEQ(d,"chomp")) return -KEY_chomp;
5461 if (strEQ(d,"chmod")) return -KEY_chmod;
5462 if (strEQ(d,"chown")) return -KEY_chown;
5463 if (strEQ(d,"crypt")) return -KEY_crypt;
5466 if (strEQ(d,"chroot")) return -KEY_chroot;
5467 if (strEQ(d,"caller")) return -KEY_caller;
5470 if (strEQ(d,"connect")) return -KEY_connect;
5473 if (strEQ(d,"closedir")) return -KEY_closedir;
5474 if (strEQ(d,"continue")) return -KEY_continue;
5479 if (strEQ(d,"DESTROY")) return KEY_DESTROY;
5484 if (strEQ(d,"do")) return KEY_do;
5487 if (strEQ(d,"die")) return -KEY_die;
5490 if (strEQ(d,"dump")) return -KEY_dump;
5493 if (strEQ(d,"delete")) return KEY_delete;
5496 if (strEQ(d,"defined")) return KEY_defined;
5497 if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
5500 if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
5505 if (strEQ(d,"END")) return KEY_END;
5510 if (strEQ(d,"eq")) return -KEY_eq;
5513 if (strEQ(d,"eof")) return -KEY_eof;
5514 if (strEQ(d,"err")) return -KEY_err;
5515 if (strEQ(d,"exp")) return -KEY_exp;
5518 if (strEQ(d,"else")) return KEY_else;
5519 if (strEQ(d,"exit")) return -KEY_exit;
5520 if (strEQ(d,"eval")) return KEY_eval;
5521 if (strEQ(d,"exec")) return -KEY_exec;
5522 if (strEQ(d,"each")) return -KEY_each;
5525 if (strEQ(d,"elsif")) return KEY_elsif;
5528 if (strEQ(d,"exists")) return KEY_exists;
5529 if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5532 if (strEQ(d,"endgrent")) return -KEY_endgrent;
5533 if (strEQ(d,"endpwent")) return -KEY_endpwent;
5536 if (strEQ(d,"endnetent")) return -KEY_endnetent;
5539 if (strEQ(d,"endhostent")) return -KEY_endhostent;
5540 if (strEQ(d,"endservent")) return -KEY_endservent;
5543 if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
5550 if (strEQ(d,"for")) return KEY_for;
5553 if (strEQ(d,"fork")) return -KEY_fork;
5556 if (strEQ(d,"fcntl")) return -KEY_fcntl;
5557 if (strEQ(d,"flock")) return -KEY_flock;
5560 if (strEQ(d,"format")) return KEY_format;
5561 if (strEQ(d,"fileno")) return -KEY_fileno;
5564 if (strEQ(d,"foreach")) return KEY_foreach;
5567 if (strEQ(d,"formline")) return -KEY_formline;
5572 if (strnEQ(d,"get",3)) {
5577 if (strEQ(d,"ppid")) return -KEY_getppid;
5578 if (strEQ(d,"pgrp")) return -KEY_getpgrp;
5581 if (strEQ(d,"pwent")) return -KEY_getpwent;
5582 if (strEQ(d,"pwnam")) return -KEY_getpwnam;
5583 if (strEQ(d,"pwuid")) return -KEY_getpwuid;
5586 if (strEQ(d,"peername")) return -KEY_getpeername;
5587 if (strEQ(d,"protoent")) return -KEY_getprotoent;
5588 if (strEQ(d,"priority")) return -KEY_getpriority;
5591 if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5594 if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5598 else if (*d == 'h') {
5599 if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
5600 if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
5601 if (strEQ(d,"hostent")) return -KEY_gethostent;
5603 else if (*d == 'n') {
5604 if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
5605 if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
5606 if (strEQ(d,"netent")) return -KEY_getnetent;
5608 else if (*d == 's') {
5609 if (strEQ(d,"servbyname")) return -KEY_getservbyname;
5610 if (strEQ(d,"servbyport")) return -KEY_getservbyport;
5611 if (strEQ(d,"servent")) return -KEY_getservent;
5612 if (strEQ(d,"sockname")) return -KEY_getsockname;
5613 if (strEQ(d,"sockopt")) return -KEY_getsockopt;
5615 else if (*d == 'g') {
5616 if (strEQ(d,"grent")) return -KEY_getgrent;
5617 if (strEQ(d,"grnam")) return -KEY_getgrnam;
5618 if (strEQ(d,"grgid")) return -KEY_getgrgid;
5620 else if (*d == 'l') {
5621 if (strEQ(d,"login")) return -KEY_getlogin;
5623 else if (strEQ(d,"c")) return -KEY_getc;
5628 if (strEQ(d,"gt")) return -KEY_gt;
5629 if (strEQ(d,"ge")) return -KEY_ge;
5632 if (strEQ(d,"grep")) return KEY_grep;
5633 if (strEQ(d,"goto")) return KEY_goto;
5634 if (strEQ(d,"glob")) return KEY_glob;
5637 if (strEQ(d,"gmtime")) return -KEY_gmtime;
5642 if (strEQ(d,"hex")) return -KEY_hex;
5645 if (strEQ(d,"INIT")) return KEY_INIT;
5650 if (strEQ(d,"if")) return KEY_if;
5653 if (strEQ(d,"int")) return -KEY_int;
5656 if (strEQ(d,"index")) return -KEY_index;
5657 if (strEQ(d,"ioctl")) return -KEY_ioctl;
5662 if (strEQ(d,"join")) return -KEY_join;
5666 if (strEQ(d,"keys")) return -KEY_keys;
5667 if (strEQ(d,"kill")) return -KEY_kill;
5673 if (strEQ(d,"lt")) return -KEY_lt;
5674 if (strEQ(d,"le")) return -KEY_le;
5675 if (strEQ(d,"lc")) return -KEY_lc;
5678 if (strEQ(d,"log")) return -KEY_log;
5681 if (strEQ(d,"last")) return KEY_last;
5682 if (strEQ(d,"link")) return -KEY_link;
5683 if (strEQ(d,"lock")) return -KEY_lock;
5686 if (strEQ(d,"local")) return KEY_local;
5687 if (strEQ(d,"lstat")) return -KEY_lstat;
5690 if (strEQ(d,"length")) return -KEY_length;
5691 if (strEQ(d,"listen")) return -KEY_listen;
5694 if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
5697 if (strEQ(d,"localtime")) return -KEY_localtime;
5703 case 1: return KEY_m;
5705 if (strEQ(d,"my")) return KEY_my;
5708 if (strEQ(d,"map")) return KEY_map;
5711 if (strEQ(d,"mkdir")) return -KEY_mkdir;
5714 if (strEQ(d,"msgctl")) return -KEY_msgctl;
5715 if (strEQ(d,"msgget")) return -KEY_msgget;
5716 if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
5717 if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
5722 if (strEQ(d,"next")) return KEY_next;
5723 if (strEQ(d,"ne")) return -KEY_ne;
5724 if (strEQ(d,"not")) return -KEY_not;
5725 if (strEQ(d,"no")) return KEY_no;
5730 if (strEQ(d,"or")) return -KEY_or;
5733 if (strEQ(d,"ord")) return -KEY_ord;
5734 if (strEQ(d,"oct")) return -KEY_oct;
5735 if (strEQ(d,"our")) return KEY_our;
5738 if (strEQ(d,"open")) return -KEY_open;
5741 if (strEQ(d,"opendir")) return -KEY_opendir;
5748 if (strEQ(d,"pop")) return -KEY_pop;
5749 if (strEQ(d,"pos")) return KEY_pos;
5752 if (strEQ(d,"push")) return -KEY_push;
5753 if (strEQ(d,"pack")) return -KEY_pack;
5754 if (strEQ(d,"pipe")) return -KEY_pipe;
5757 if (strEQ(d,"print")) return KEY_print;
5760 if (strEQ(d,"printf")) return KEY_printf;
5763 if (strEQ(d,"package")) return KEY_package;
5766 if (strEQ(d,"prototype")) return KEY_prototype;
5771 if (strEQ(d,"q")) return KEY_q;
5772 if (strEQ(d,"qr")) return KEY_qr;
5773 if (strEQ(d,"qq")) return KEY_qq;
5774 if (strEQ(d,"qw")) return KEY_qw;
5775 if (strEQ(d,"qx")) return KEY_qx;
5777 else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
5782 if (strEQ(d,"ref")) return -KEY_ref;
5785 if (strEQ(d,"read")) return -KEY_read;
5786 if (strEQ(d,"rand")) return -KEY_rand;
5787 if (strEQ(d,"recv")) return -KEY_recv;
5788 if (strEQ(d,"redo")) return KEY_redo;
5791 if (strEQ(d,"rmdir")) return -KEY_rmdir;
5792 if (strEQ(d,"reset")) return -KEY_reset;
5795 if (strEQ(d,"return")) return KEY_return;
5796 if (strEQ(d,"rename")) return -KEY_rename;
5797 if (strEQ(d,"rindex")) return -KEY_rindex;
5800 if (strEQ(d,"require")) return KEY_require;
5801 if (strEQ(d,"reverse")) return -KEY_reverse;
5802 if (strEQ(d,"readdir")) return -KEY_readdir;
5805 if (strEQ(d,"readlink")) return -KEY_readlink;
5806 if (strEQ(d,"readline")) return -KEY_readline;
5807 if (strEQ(d,"readpipe")) return -KEY_readpipe;
5810 if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
5816 case 0: return KEY_s;
5818 if (strEQ(d,"scalar")) return KEY_scalar;
5823 if (strEQ(d,"seek")) return -KEY_seek;
5824 if (strEQ(d,"send")) return -KEY_send;
5827 if (strEQ(d,"semop")) return -KEY_semop;
5830 if (strEQ(d,"select")) return -KEY_select;
5831 if (strEQ(d,"semctl")) return -KEY_semctl;
5832 if (strEQ(d,"semget")) return -KEY_semget;
5835 if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
5836 if (strEQ(d,"seekdir")) return -KEY_seekdir;
5839 if (strEQ(d,"setpwent")) return -KEY_setpwent;
5840 if (strEQ(d,"setgrent")) return -KEY_setgrent;
5843 if (strEQ(d,"setnetent")) return -KEY_setnetent;
5846 if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
5847 if (strEQ(d,"sethostent")) return -KEY_sethostent;
5848 if (strEQ(d,"setservent")) return -KEY_setservent;
5851 if (strEQ(d,"setpriority")) return -KEY_setpriority;
5852 if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
5859 if (strEQ(d,"shift")) return -KEY_shift;
5862 if (strEQ(d,"shmctl")) return -KEY_shmctl;
5863 if (strEQ(d,"shmget")) return -KEY_shmget;
5866 if (strEQ(d,"shmread")) return -KEY_shmread;
5869 if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
5870 if (strEQ(d,"shutdown")) return -KEY_shutdown;
5875 if (strEQ(d,"sin")) return -KEY_sin;
5878 if (strEQ(d,"sleep")) return -KEY_sleep;
5881 if (strEQ(d,"sort")) return KEY_sort;
5882 if (strEQ(d,"socket")) return -KEY_socket;
5883 if (strEQ(d,"socketpair")) return -KEY_socketpair;
5886 if (strEQ(d,"split")) return KEY_split;
5887 if (strEQ(d,"sprintf")) return -KEY_sprintf;
5888 if (strEQ(d,"splice")) return -KEY_splice;
5891 if (strEQ(d,"sqrt")) return -KEY_sqrt;
5894 if (strEQ(d,"srand")) return -KEY_srand;
5897 if (strEQ(d,"stat")) return -KEY_stat;
5898 if (strEQ(d,"study")) return KEY_study;
5901 if (strEQ(d,"substr")) return -KEY_substr;
5902 if (strEQ(d,"sub")) return KEY_sub;
5907 if (strEQ(d,"system")) return -KEY_system;
5910 if (strEQ(d,"symlink")) return -KEY_symlink;
5911 if (strEQ(d,"syscall")) return -KEY_syscall;
5912 if (strEQ(d,"sysopen")) return -KEY_sysopen;
5913 if (strEQ(d,"sysread")) return -KEY_sysread;
5914 if (strEQ(d,"sysseek")) return -KEY_sysseek;
5917 if (strEQ(d,"syswrite")) return -KEY_syswrite;
5926 if (strEQ(d,"tr")) return KEY_tr;
5929 if (strEQ(d,"tie")) return KEY_tie;
5932 if (strEQ(d,"tell")) return -KEY_tell;
5933 if (strEQ(d,"tied")) return KEY_tied;
5934 if (strEQ(d,"time")) return -KEY_time;
5937 if (strEQ(d,"times")) return -KEY_times;
5940 if (strEQ(d,"telldir")) return -KEY_telldir;
5943 if (strEQ(d,"truncate")) return -KEY_truncate;
5950 if (strEQ(d,"uc")) return -KEY_uc;
5953 if (strEQ(d,"use")) return KEY_use;
5956 if (strEQ(d,"undef")) return KEY_undef;
5957 if (strEQ(d,"until")) return KEY_until;
5958 if (strEQ(d,"untie")) return KEY_untie;
5959 if (strEQ(d,"utime")) return -KEY_utime;
5960 if (strEQ(d,"umask")) return -KEY_umask;
5963 if (strEQ(d,"unless")) return KEY_unless;
5964 if (strEQ(d,"unpack")) return -KEY_unpack;
5965 if (strEQ(d,"unlink")) return -KEY_unlink;
5968 if (strEQ(d,"unshift")) return -KEY_unshift;
5969 if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
5974 if (strEQ(d,"values")) return -KEY_values;
5975 if (strEQ(d,"vec")) return -KEY_vec;
5980 if (strEQ(d,"warn")) return -KEY_warn;
5981 if (strEQ(d,"wait")) return -KEY_wait;
5984 if (strEQ(d,"while")) return KEY_while;
5985 if (strEQ(d,"write")) return -KEY_write;
5988 if (strEQ(d,"waitpid")) return -KEY_waitpid;
5991 if (strEQ(d,"wantarray")) return -KEY_wantarray;
5996 if (len == 1) return -KEY_x;
5997 if (strEQ(d,"xor")) return -KEY_xor;
6000 if (len == 1) return KEY_y;
6009 S_checkcomma(pTHX_ register char *s, char *name, char *what)
6013 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
6014 if (ckWARN(WARN_SYNTAX)) {
6016 for (w = s+2; *w && level; w++) {
6023 for (; *w && isSPACE(*w); w++) ;
6024 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
6025 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6026 "%s (...) interpreted as function",name);
6029 while (s < PL_bufend && isSPACE(*s))
6033 while (s < PL_bufend && isSPACE(*s))
6035 if (isIDFIRST_lazy_if(s,UTF)) {
6037 while (isALNUM_lazy_if(s,UTF))
6039 while (s < PL_bufend && isSPACE(*s))
6044 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
6048 Perl_croak(aTHX_ "No comma allowed after %s", what);
6053 /* Either returns sv, or mortalizes sv and returns a new SV*.
6054 Best used as sv=new_constant(..., sv, ...).
6055 If s, pv are NULL, calls subroutine with one argument,
6056 and type is used with error messages only. */
6059 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
6063 HV *table = GvHV(PL_hintgv); /* ^H */
6067 const char *why1, *why2, *why3;
6069 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
6072 why2 = strEQ(key,"charnames")
6073 ? "(possibly a missing \"use charnames ...\")"
6075 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
6076 (type ? type: "undef"), why2);
6078 /* This is convoluted and evil ("goto considered harmful")
6079 * but I do not understand the intricacies of all the different
6080 * failure modes of %^H in here. The goal here is to make
6081 * the most probable error message user-friendly. --jhi */
6086 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
6087 (type ? type: "undef"), why1, why2, why3);
6089 yyerror(SvPVX(msg));
6093 cvp = hv_fetch(table, key, strlen(key), FALSE);
6094 if (!cvp || !SvOK(*cvp)) {
6097 why3 = "} is not defined";
6100 sv_2mortal(sv); /* Parent created it permanently */
6103 pv = sv_2mortal(newSVpvn(s, len));
6105 typesv = sv_2mortal(newSVpv(type, 0));
6107 typesv = &PL_sv_undef;
6109 PUSHSTACKi(PERLSI_OVERLOAD);
6121 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
6125 /* Check the eval first */
6126 if (!PL_in_eval && SvTRUE(ERRSV)) {
6128 sv_catpv(ERRSV, "Propagated");
6129 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6131 res = SvREFCNT_inc(sv);
6135 (void)SvREFCNT_inc(res);
6144 why1 = "Call to &{$^H{";
6146 why3 = "}} did not return a defined value";
6155 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6157 register char *d = dest;
6158 register char *e = d + destlen - 3; /* two-character token, ending NUL */
6161 Perl_croak(aTHX_ ident_too_long);
6162 if (isALNUM(*s)) /* UTF handled below */
6164 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6169 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6173 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6174 char *t = s + UTF8SKIP(s);
6175 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6177 if (d + (t - s) > e)
6178 Perl_croak(aTHX_ ident_too_long);
6179 Copy(s, d, t - s, char);
6192 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6202 e = d + destlen - 3; /* two-character token, ending NUL */
6204 while (isDIGIT(*s)) {
6206 Perl_croak(aTHX_ ident_too_long);
6213 Perl_croak(aTHX_ ident_too_long);
6214 if (isALNUM(*s)) /* UTF handled below */
6216 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6221 else if (*s == ':' && s[1] == ':') {
6225 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6226 char *t = s + UTF8SKIP(s);
6227 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6229 if (d + (t - s) > e)
6230 Perl_croak(aTHX_ ident_too_long);
6231 Copy(s, d, t - s, char);
6242 if (PL_lex_state != LEX_NORMAL)
6243 PL_lex_state = LEX_INTERPENDMAYBE;
6246 if (*s == '$' && s[1] &&
6247 (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6260 if (*d == '^' && *s && isCONTROLVAR(*s)) {
6265 if (isSPACE(s[-1])) {
6268 if (!SPACE_OR_TAB(ch)) {
6274 if (isIDFIRST_lazy_if(d,UTF)) {
6278 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6280 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6283 Copy(s, d, e - s, char);
6288 while ((isALNUM(*s) || *s == ':') && d < e)
6291 Perl_croak(aTHX_ ident_too_long);
6294 while (s < send && SPACE_OR_TAB(*s)) s++;
6295 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6296 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6297 const char *brack = *s == '[' ? "[...]" : "{...}";
6298 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6299 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6300 funny, dest, brack, funny, dest, brack);
6303 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6307 /* Handle extended ${^Foo} variables
6308 * 1999-02-27 mjd-perl-patch@plover.com */
6309 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6313 while (isALNUM(*s) && d < e) {
6317 Perl_croak(aTHX_ ident_too_long);
6322 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
6323 PL_lex_state = LEX_INTERPEND;
6328 if (PL_lex_state == LEX_NORMAL) {
6329 if (ckWARN(WARN_AMBIGUOUS) &&
6330 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6332 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6333 "Ambiguous use of %c{%s} resolved to %c%s",
6334 funny, dest, funny, dest);
6339 s = bracket; /* let the parser handle it */
6343 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6344 PL_lex_state = LEX_INTERPEND;
6349 Perl_pmflag(pTHX_ U32* pmfl, int ch)
6354 *pmfl |= PMf_GLOBAL;
6356 *pmfl |= PMf_CONTINUE;
6360 *pmfl |= PMf_MULTILINE;
6362 *pmfl |= PMf_SINGLELINE;
6364 *pmfl |= PMf_EXTENDED;
6368 S_scan_pat(pTHX_ char *start, I32 type)
6373 s = scan_str(start,FALSE,FALSE);
6375 Perl_croak(aTHX_ "Search pattern not terminated");
6377 pm = (PMOP*)newPMOP(type, 0);
6378 if (PL_multi_open == '?')
6379 pm->op_pmflags |= PMf_ONCE;
6381 while (*s && strchr("iomsx", *s))
6382 pmflag(&pm->op_pmflags,*s++);
6385 while (*s && strchr("iogcmsx", *s))
6386 pmflag(&pm->op_pmflags,*s++);
6388 /* issue a warning if /c is specified,but /g is not */
6389 if (ckWARN(WARN_REGEXP) &&
6390 (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
6392 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
6395 pm->op_pmpermflags = pm->op_pmflags;
6397 PL_lex_op = (OP*)pm;
6398 yylval.ival = OP_MATCH;
6403 S_scan_subst(pTHX_ char *start)
6410 yylval.ival = OP_NULL;
6412 s = scan_str(start,FALSE,FALSE);
6415 Perl_croak(aTHX_ "Substitution pattern not terminated");
6417 if (s[-1] == PL_multi_open)
6420 first_start = PL_multi_start;
6421 s = scan_str(s,FALSE,FALSE);
6424 SvREFCNT_dec(PL_lex_stuff);
6425 PL_lex_stuff = Nullsv;
6427 Perl_croak(aTHX_ "Substitution replacement not terminated");
6429 PL_multi_start = first_start; /* so whole substitution is taken together */
6431 pm = (PMOP*)newPMOP(OP_SUBST, 0);
6437 else if (strchr("iogcmsx", *s))
6438 pmflag(&pm->op_pmflags,*s++);
6443 /* /c is not meaningful with s/// */
6444 if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
6446 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
6451 PL_sublex_info.super_bufptr = s;
6452 PL_sublex_info.super_bufend = PL_bufend;
6454 pm->op_pmflags |= PMf_EVAL;
6455 repl = newSVpvn("",0);
6457 sv_catpv(repl, es ? "eval " : "do ");
6458 sv_catpvn(repl, "{ ", 2);
6459 sv_catsv(repl, PL_lex_repl);
6460 sv_catpvn(repl, " };", 2);
6462 SvREFCNT_dec(PL_lex_repl);
6466 pm->op_pmpermflags = pm->op_pmflags;
6467 PL_lex_op = (OP*)pm;
6468 yylval.ival = OP_SUBST;
6473 S_scan_trans(pTHX_ char *start)
6482 yylval.ival = OP_NULL;
6484 s = scan_str(start,FALSE,FALSE);
6486 Perl_croak(aTHX_ "Transliteration pattern not terminated");
6487 if (s[-1] == PL_multi_open)
6490 s = scan_str(s,FALSE,FALSE);
6493 SvREFCNT_dec(PL_lex_stuff);
6494 PL_lex_stuff = Nullsv;
6496 Perl_croak(aTHX_ "Transliteration replacement not terminated");
6499 complement = del = squash = 0;
6500 while (strchr("cds", *s)) {
6502 complement = OPpTRANS_COMPLEMENT;
6504 del = OPpTRANS_DELETE;
6506 squash = OPpTRANS_SQUASH;
6510 New(803, tbl, complement&&!del?258:256, short);
6511 o = newPVOP(OP_TRANS, 0, (char*)tbl);
6512 o->op_private = del|squash|complement|
6513 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6514 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
6517 yylval.ival = OP_TRANS;
6522 S_scan_heredoc(pTHX_ register char *s)
6525 I32 op_type = OP_SCALAR;
6532 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6536 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6539 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6540 if (*peek && strchr("`'\"",*peek)) {
6543 s = delimcpy(d, e, s, PL_bufend, term, &len);
6553 if (!isALNUM_lazy_if(s,UTF))
6554 deprecate_old("bare << to mean <<\"\"");
6555 for (; isALNUM_lazy_if(s,UTF); s++) {
6560 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6561 Perl_croak(aTHX_ "Delimiter for here document is too long");
6564 len = d - PL_tokenbuf;
6565 #ifndef PERL_STRICT_CR
6566 d = strchr(s, '\r');
6570 while (s < PL_bufend) {
6576 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
6585 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6590 if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6591 herewas = newSVpvn(s,PL_bufend-s);
6593 s--, herewas = newSVpvn(s,d-s);
6594 s += SvCUR(herewas);
6596 tmpstr = NEWSV(87,79);
6597 sv_upgrade(tmpstr, SVt_PVIV);
6602 else if (term == '`') {
6603 op_type = OP_BACKTICK;
6604 SvIVX(tmpstr) = '\\';
6608 PL_multi_start = CopLINE(PL_curcop);
6609 PL_multi_open = PL_multi_close = '<';
6610 term = *PL_tokenbuf;
6611 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6612 char *bufptr = PL_sublex_info.super_bufptr;
6613 char *bufend = PL_sublex_info.super_bufend;
6614 char *olds = s - SvCUR(herewas);
6615 s = strchr(bufptr, '\n');
6619 while (s < bufend &&
6620 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6622 CopLINE_inc(PL_curcop);
6625 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6626 missingterm(PL_tokenbuf);
6628 sv_setpvn(herewas,bufptr,d-bufptr+1);
6629 sv_setpvn(tmpstr,d+1,s-d);
6631 sv_catpvn(herewas,s,bufend-s);
6632 (void)strcpy(bufptr,SvPVX(herewas));
6639 while (s < PL_bufend &&
6640 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6642 CopLINE_inc(PL_curcop);
6644 if (s >= PL_bufend) {
6645 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6646 missingterm(PL_tokenbuf);
6648 sv_setpvn(tmpstr,d+1,s-d);
6650 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6652 sv_catpvn(herewas,s,PL_bufend-s);
6653 sv_setsv(PL_linestr,herewas);
6654 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6655 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6656 PL_last_lop = PL_last_uni = Nullch;
6659 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
6660 while (s >= PL_bufend) { /* multiple line string? */
6662 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6663 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6664 missingterm(PL_tokenbuf);
6666 CopLINE_inc(PL_curcop);
6667 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6668 PL_last_lop = PL_last_uni = Nullch;
6669 #ifndef PERL_STRICT_CR
6670 if (PL_bufend - PL_linestart >= 2) {
6671 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6672 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6674 PL_bufend[-2] = '\n';
6676 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6678 else if (PL_bufend[-1] == '\r')
6679 PL_bufend[-1] = '\n';
6681 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6682 PL_bufend[-1] = '\n';
6684 if (PERLDB_LINE && PL_curstash != PL_debstash) {
6685 SV *sv = NEWSV(88,0);
6687 sv_upgrade(sv, SVt_PVMG);
6688 sv_setsv(sv,PL_linestr);
6691 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6693 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6696 sv_catsv(PL_linestr,herewas);
6697 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6701 sv_catsv(tmpstr,PL_linestr);
6706 PL_multi_end = CopLINE(PL_curcop);
6707 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6708 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6709 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6711 SvREFCNT_dec(herewas);
6713 if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6715 else if (PL_encoding)
6716 sv_recode_to_utf8(tmpstr, PL_encoding);
6718 PL_lex_stuff = tmpstr;
6719 yylval.ival = op_type;
6724 takes: current position in input buffer
6725 returns: new position in input buffer
6726 side-effects: yylval and lex_op are set.
6731 <FH> read from filehandle
6732 <pkg::FH> read from package qualified filehandle
6733 <pkg'FH> read from package qualified filehandle
6734 <$fh> read from filehandle in $fh
6740 S_scan_inputsymbol(pTHX_ char *start)
6742 register char *s = start; /* current position in buffer */
6748 d = PL_tokenbuf; /* start of temp holding space */
6749 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
6750 end = strchr(s, '\n');
6753 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
6755 /* die if we didn't have space for the contents of the <>,
6756 or if it didn't end, or if we see a newline
6759 if (len >= sizeof PL_tokenbuf)
6760 Perl_croak(aTHX_ "Excessively long <> operator");
6762 Perl_croak(aTHX_ "Unterminated <> operator");
6767 Remember, only scalar variables are interpreted as filehandles by
6768 this code. Anything more complex (e.g., <$fh{$num}>) will be
6769 treated as a glob() call.
6770 This code makes use of the fact that except for the $ at the front,
6771 a scalar variable and a filehandle look the same.
6773 if (*d == '$' && d[1]) d++;
6775 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6776 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6779 /* If we've tried to read what we allow filehandles to look like, and
6780 there's still text left, then it must be a glob() and not a getline.
6781 Use scan_str to pull out the stuff between the <> and treat it
6782 as nothing more than a string.
6785 if (d - PL_tokenbuf != len) {
6786 yylval.ival = OP_GLOB;
6788 s = scan_str(start,FALSE,FALSE);
6790 Perl_croak(aTHX_ "Glob not terminated");
6794 bool readline_overriden = FALSE;
6795 GV *gv_readline = Nullgv;
6797 /* we're in a filehandle read situation */
6800 /* turn <> into <ARGV> */
6802 (void)strcpy(d,"ARGV");
6804 /* Check whether readline() is overriden */
6805 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
6806 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
6808 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
6809 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
6810 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
6811 readline_overriden = TRUE;
6813 /* if <$fh>, create the ops to turn the variable into a
6819 /* try to find it in the pad for this block, otherwise find
6820 add symbol table ops
6822 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6823 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
6824 SV *sym = sv_2mortal(
6825 newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0));
6826 sv_catpvn(sym, "::", 2);
6832 OP *o = newOP(OP_PADSV, 0);
6834 PL_lex_op = readline_overriden
6835 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6836 append_elem(OP_LIST, o,
6837 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
6838 : (OP*)newUNOP(OP_READLINE, 0, o);
6847 ? (GV_ADDMULTI | GV_ADDINEVAL)
6850 PL_lex_op = readline_overriden
6851 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6852 append_elem(OP_LIST,
6853 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
6854 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6855 : (OP*)newUNOP(OP_READLINE, 0,
6856 newUNOP(OP_RV2SV, 0,
6857 newGVOP(OP_GV, 0, gv)));
6859 if (!readline_overriden)
6860 PL_lex_op->op_flags |= OPf_SPECIAL;
6861 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6862 yylval.ival = OP_NULL;
6865 /* If it's none of the above, it must be a literal filehandle
6866 (<Foo::BAR> or <FOO>) so build a simple readline OP */
6868 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6869 PL_lex_op = readline_overriden
6870 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6871 append_elem(OP_LIST,
6872 newGVOP(OP_GV, 0, gv),
6873 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6874 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6875 yylval.ival = OP_NULL;
6884 takes: start position in buffer
6885 keep_quoted preserve \ on the embedded delimiter(s)
6886 keep_delims preserve the delimiters around the string
6887 returns: position to continue reading from buffer
6888 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6889 updates the read buffer.
6891 This subroutine pulls a string out of the input. It is called for:
6892 q single quotes q(literal text)
6893 ' single quotes 'literal text'
6894 qq double quotes qq(interpolate $here please)
6895 " double quotes "interpolate $here please"
6896 qx backticks qx(/bin/ls -l)
6897 ` backticks `/bin/ls -l`
6898 qw quote words @EXPORT_OK = qw( func() $spam )
6899 m// regexp match m/this/
6900 s/// regexp substitute s/this/that/
6901 tr/// string transliterate tr/this/that/
6902 y/// string transliterate y/this/that/
6903 ($*@) sub prototypes sub foo ($)
6904 (stuff) sub attr parameters sub foo : attr(stuff)
6905 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
6907 In most of these cases (all but <>, patterns and transliterate)
6908 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
6909 calls scan_str(). s/// makes yylex() call scan_subst() which calls
6910 scan_str(). tr/// and y/// make yylex() call scan_trans() which
6913 It skips whitespace before the string starts, and treats the first
6914 character as the delimiter. If the delimiter is one of ([{< then
6915 the corresponding "close" character )]}> is used as the closing
6916 delimiter. It allows quoting of delimiters, and if the string has
6917 balanced delimiters ([{<>}]) it allows nesting.
6919 On success, the SV with the resulting string is put into lex_stuff or,
6920 if that is already non-NULL, into lex_repl. The second case occurs only
6921 when parsing the RHS of the special constructs s/// and tr/// (y///).
6922 For convenience, the terminating delimiter character is stuffed into
6927 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6929 SV *sv; /* scalar value: string */
6930 char *tmps; /* temp string, used for delimiter matching */
6931 register char *s = start; /* current position in the buffer */
6932 register char term; /* terminating character */
6933 register char *to; /* current position in the sv's data */
6934 I32 brackets = 1; /* bracket nesting level */
6935 bool has_utf8 = FALSE; /* is there any utf8 content? */
6936 I32 termcode; /* terminating char. code */
6937 U8 termstr[UTF8_MAXLEN]; /* terminating string */
6938 STRLEN termlen; /* length of terminating string */
6939 char *last = NULL; /* last position for nesting bracket */
6941 /* skip space before the delimiter */
6945 /* mark where we are, in case we need to report errors */
6948 /* after skipping whitespace, the next character is the terminator */
6951 termcode = termstr[0] = term;
6955 termcode = utf8_to_uvchr((U8*)s, &termlen);
6956 Copy(s, termstr, termlen, U8);
6957 if (!UTF8_IS_INVARIANT(term))
6961 /* mark where we are */
6962 PL_multi_start = CopLINE(PL_curcop);
6963 PL_multi_open = term;
6965 /* find corresponding closing delimiter */
6966 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6967 termcode = termstr[0] = term = tmps[5];
6969 PL_multi_close = term;
6971 /* create a new SV to hold the contents. 87 is leak category, I'm
6972 assuming. 79 is the SV's initial length. What a random number. */
6974 sv_upgrade(sv, SVt_PVIV);
6975 SvIVX(sv) = termcode;
6976 (void)SvPOK_only(sv); /* validate pointer */
6978 /* move past delimiter and try to read a complete string */
6980 sv_catpvn(sv, s, termlen);
6983 if (PL_encoding && !UTF) {
6987 int offset = s - SvPVX(PL_linestr);
6988 bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
6989 &offset, (char*)termstr, termlen);
6990 char *ns = SvPVX(PL_linestr) + offset;
6991 char *svlast = SvEND(sv) - 1;
6993 for (; s < ns; s++) {
6994 if (*s == '\n' && !PL_rsfp)
6995 CopLINE_inc(PL_curcop);
6998 goto read_more_line;
7000 /* handle quoted delimiters */
7001 if (*(svlast-1) == '\\') {
7003 for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';)
7005 if ((svlast-1 - t) % 2) {
7009 SvCUR_set(sv, SvCUR(sv) - 1);
7014 if (PL_multi_open == PL_multi_close) {
7021 for (w = t = last; t < svlast; w++, t++) {
7022 /* At here, all closes are "was quoted" one,
7023 so we don't check PL_multi_close. */
7025 if (!keep_quoted && *(t+1) == PL_multi_open)
7030 else if (*t == PL_multi_open)
7038 SvCUR_set(sv, w - SvPVX(sv));
7041 if (--brackets <= 0)
7047 SvCUR_set(sv, SvCUR(sv) - 1);
7053 /* extend sv if need be */
7054 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
7055 /* set 'to' to the next character in the sv's string */
7056 to = SvPVX(sv)+SvCUR(sv);
7058 /* if open delimiter is the close delimiter read unbridle */
7059 if (PL_multi_open == PL_multi_close) {
7060 for (; s < PL_bufend; s++,to++) {
7061 /* embedded newlines increment the current line number */
7062 if (*s == '\n' && !PL_rsfp)
7063 CopLINE_inc(PL_curcop);
7064 /* handle quoted delimiters */
7065 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
7066 if (!keep_quoted && s[1] == term)
7068 /* any other quotes are simply copied straight through */
7072 /* terminate when run out of buffer (the for() condition), or
7073 have found the terminator */
7074 else if (*s == term) {
7077 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
7080 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7086 /* if the terminator isn't the same as the start character (e.g.,
7087 matched brackets), we have to allow more in the quoting, and
7088 be prepared for nested brackets.
7091 /* read until we run out of string, or we find the terminator */
7092 for (; s < PL_bufend; s++,to++) {
7093 /* embedded newlines increment the line count */
7094 if (*s == '\n' && !PL_rsfp)
7095 CopLINE_inc(PL_curcop);
7096 /* backslashes can escape the open or closing characters */
7097 if (*s == '\\' && s+1 < PL_bufend) {
7099 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
7104 /* allow nested opens and closes */
7105 else if (*s == PL_multi_close && --brackets <= 0)
7107 else if (*s == PL_multi_open)
7109 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7114 /* terminate the copied string and update the sv's end-of-string */
7116 SvCUR_set(sv, to - SvPVX(sv));
7119 * this next chunk reads more into the buffer if we're not done yet
7123 break; /* handle case where we are done yet :-) */
7125 #ifndef PERL_STRICT_CR
7126 if (to - SvPVX(sv) >= 2) {
7127 if ((to[-2] == '\r' && to[-1] == '\n') ||
7128 (to[-2] == '\n' && to[-1] == '\r'))
7132 SvCUR_set(sv, to - SvPVX(sv));
7134 else if (to[-1] == '\r')
7137 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
7142 /* if we're out of file, or a read fails, bail and reset the current
7143 line marker so we can report where the unterminated string began
7146 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
7148 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
7151 /* we read a line, so increment our line counter */
7152 CopLINE_inc(PL_curcop);
7154 /* update debugger info */
7155 if (PERLDB_LINE && PL_curstash != PL_debstash) {
7156 SV *sv = NEWSV(88,0);
7158 sv_upgrade(sv, SVt_PVMG);
7159 sv_setsv(sv,PL_linestr);
7162 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
7165 /* having changed the buffer, we must update PL_bufend */
7166 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7167 PL_last_lop = PL_last_uni = Nullch;
7170 /* at this point, we have successfully read the delimited string */
7172 if (!PL_encoding || UTF) {
7174 sv_catpvn(sv, s, termlen);
7177 if (has_utf8 || PL_encoding)
7180 PL_multi_end = CopLINE(PL_curcop);
7182 /* if we allocated too much space, give some back */
7183 if (SvCUR(sv) + 5 < SvLEN(sv)) {
7184 SvLEN_set(sv, SvCUR(sv) + 1);
7185 Renew(SvPVX(sv), SvLEN(sv), char);
7188 /* decide whether this is the first or second quoted string we've read
7201 takes: pointer to position in buffer
7202 returns: pointer to new position in buffer
7203 side-effects: builds ops for the constant in yylval.op
7205 Read a number in any of the formats that Perl accepts:
7207 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
7208 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
7211 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
7213 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
7216 If it reads a number without a decimal point or an exponent, it will
7217 try converting the number to an integer and see if it can do so
7218 without loss of precision.
7222 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
7224 register char *s = start; /* current position in buffer */
7225 register char *d; /* destination in temp buffer */
7226 register char *e; /* end of temp buffer */
7227 NV nv; /* number read, as a double */
7228 SV *sv = Nullsv; /* place to put the converted number */
7229 bool floatit; /* boolean: int or float? */
7230 char *lastub = 0; /* position of last underbar */
7231 static char number_too_long[] = "Number too long";
7233 /* We use the first character to decide what type of number this is */
7237 Perl_croak(aTHX_ "panic: scan_num");
7239 /* if it starts with a 0, it could be an octal number, a decimal in
7240 0.13 disguise, or a hexadecimal number, or a binary number. */
7244 u holds the "number so far"
7245 shift the power of 2 of the base
7246 (hex == 4, octal == 3, binary == 1)
7247 overflowed was the number more than we can hold?
7249 Shift is used when we add a digit. It also serves as an "are
7250 we in octal/hex/binary?" indicator to disallow hex characters
7256 bool overflowed = FALSE;
7257 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7258 static char* bases[5] = { "", "binary", "", "octal",
7260 static char* Bases[5] = { "", "Binary", "", "Octal",
7262 static char *maxima[5] = { "",
7263 "0b11111111111111111111111111111111",
7267 char *base, *Base, *max;
7273 } else if (s[1] == 'b') {
7277 /* check for a decimal in disguise */
7278 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7280 /* so it must be octal */
7287 if (ckWARN(WARN_SYNTAX))
7288 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7289 "Misplaced _ in number");
7293 base = bases[shift];
7294 Base = Bases[shift];
7295 max = maxima[shift];
7297 /* read the rest of the number */
7299 /* x is used in the overflow test,
7300 b is the digit we're adding on. */
7305 /* if we don't mention it, we're done */
7309 /* _ are ignored -- but warned about if consecutive */
7311 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7312 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7313 "Misplaced _ in number");
7317 /* 8 and 9 are not octal */
7320 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7324 case '2': case '3': case '4':
7325 case '5': case '6': case '7':
7327 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7331 b = *s++ & 15; /* ASCII digit -> value of digit */
7335 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7336 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7337 /* make sure they said 0x */
7342 /* Prepare to put the digit we have onto the end
7343 of the number so far. We check for overflows.
7348 x = u << shift; /* make room for the digit */
7350 if ((x >> shift) != u
7351 && !(PL_hints & HINT_NEW_BINARY)) {
7354 if (ckWARN_d(WARN_OVERFLOW))
7355 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
7356 "Integer overflow in %s number",
7359 u = x | b; /* add the digit to the end */
7362 n *= nvshift[shift];
7363 /* If an NV has not enough bits in its
7364 * mantissa to represent an UV this summing of
7365 * small low-order numbers is a waste of time
7366 * (because the NV cannot preserve the
7367 * low-order bits anyway): we could just
7368 * remember when did we overflow and in the
7369 * end just multiply n by the right
7377 /* if we get here, we had success: make a scalar value from
7382 /* final misplaced underbar check */
7384 if (ckWARN(WARN_SYNTAX))
7385 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7390 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7391 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7392 "%s number > %s non-portable",
7398 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7399 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7400 "%s number > %s non-portable",
7405 if (PL_hints & HINT_NEW_BINARY)
7406 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7411 handle decimal numbers.
7412 we're also sent here when we read a 0 as the first digit
7414 case '1': case '2': case '3': case '4': case '5':
7415 case '6': case '7': case '8': case '9': case '.':
7418 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7421 /* read next group of digits and _ and copy into d */
7422 while (isDIGIT(*s) || *s == '_') {
7423 /* skip underscores, checking for misplaced ones
7427 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7428 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7429 "Misplaced _ in number");
7433 /* check for end of fixed-length buffer */
7435 Perl_croak(aTHX_ number_too_long);
7436 /* if we're ok, copy the character */
7441 /* final misplaced underbar check */
7442 if (lastub && s == lastub + 1) {
7443 if (ckWARN(WARN_SYNTAX))
7444 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7447 /* read a decimal portion if there is one. avoid
7448 3..5 being interpreted as the number 3. followed
7451 if (*s == '.' && s[1] != '.') {
7456 if (ckWARN(WARN_SYNTAX))
7457 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7458 "Misplaced _ in number");
7462 /* copy, ignoring underbars, until we run out of digits.
7464 for (; isDIGIT(*s) || *s == '_'; s++) {
7465 /* fixed length buffer check */
7467 Perl_croak(aTHX_ number_too_long);
7469 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7470 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7471 "Misplaced _ in number");
7477 /* fractional part ending in underbar? */
7479 if (ckWARN(WARN_SYNTAX))
7480 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7481 "Misplaced _ in number");
7483 if (*s == '.' && isDIGIT(s[1])) {
7484 /* oops, it's really a v-string, but without the "v" */
7490 /* read exponent part, if present */
7491 if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7495 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7496 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
7498 /* stray preinitial _ */
7500 if (ckWARN(WARN_SYNTAX))
7501 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7502 "Misplaced _ in number");
7506 /* allow positive or negative exponent */
7507 if (*s == '+' || *s == '-')
7510 /* stray initial _ */
7512 if (ckWARN(WARN_SYNTAX))
7513 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7514 "Misplaced _ in number");
7518 /* read digits of exponent */
7519 while (isDIGIT(*s) || *s == '_') {
7522 Perl_croak(aTHX_ number_too_long);
7526 if (ckWARN(WARN_SYNTAX) &&
7527 ((lastub && s == lastub + 1) ||
7528 (!isDIGIT(s[1]) && s[1] != '_')))
7529 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7530 "Misplaced _ in number");
7537 /* make an sv from the string */
7541 We try to do an integer conversion first if no characters
7542 indicating "float" have been found.
7547 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7549 if (flags == IS_NUMBER_IN_UV) {
7551 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7554 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7555 if (uv <= (UV) IV_MIN)
7556 sv_setiv(sv, -(IV)uv);
7563 /* terminate the string */
7565 nv = Atof(PL_tokenbuf);
7569 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7570 (PL_hints & HINT_NEW_INTEGER) )
7571 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7572 (floatit ? "float" : "integer"),
7576 /* if it starts with a v, it could be a v-string */
7579 sv = NEWSV(92,5); /* preallocate storage space */
7580 s = scan_vstring(s,sv);
7584 /* make the op for the constant and return */
7587 lvalp->opval = newSVOP(OP_CONST, 0, sv);
7589 lvalp->opval = Nullop;
7595 S_scan_formline(pTHX_ register char *s)
7599 SV *stuff = newSVpvn("",0);
7600 bool needargs = FALSE;
7603 if (*s == '.' || *s == /*{*/'}') {
7605 #ifdef PERL_STRICT_CR
7606 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7608 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7610 if (*t == '\n' || t == PL_bufend)
7613 if (PL_in_eval && !PL_rsfp) {
7614 eol = strchr(s,'\n');
7619 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7621 for (t = s; t < eol; t++) {
7622 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7624 goto enough; /* ~~ must be first line in formline */
7626 if (*t == '@' || *t == '^')
7630 sv_catpvn(stuff, s, eol-s);
7631 #ifndef PERL_STRICT_CR
7632 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7633 char *end = SvPVX(stuff) + SvCUR(stuff);
7645 s = filter_gets(PL_linestr, PL_rsfp, 0);
7646 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7647 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7648 PL_last_lop = PL_last_uni = Nullch;
7651 yyerror("Format not terminated");
7661 PL_lex_state = LEX_NORMAL;
7662 PL_nextval[PL_nexttoke].ival = 0;
7666 PL_lex_state = LEX_FORMLINE;
7668 if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff)))
7670 else if (PL_encoding)
7671 sv_recode_to_utf8(stuff, PL_encoding);
7673 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7675 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7679 SvREFCNT_dec(stuff);
7680 PL_lex_formbrack = 0;
7691 PL_cshlen = strlen(PL_cshname);
7696 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7698 I32 oldsavestack_ix = PL_savestack_ix;
7699 CV* outsidecv = PL_compcv;
7702 assert(SvTYPE(PL_compcv) == SVt_PVCV);
7704 SAVEI32(PL_subline);
7705 save_item(PL_subname);
7706 SAVESPTR(PL_compcv);
7708 PL_compcv = (CV*)NEWSV(1104,0);
7709 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7710 CvFLAGS(PL_compcv) |= flags;
7712 PL_subline = CopLINE(PL_curcop);
7713 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
7714 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7715 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
7717 return oldsavestack_ix;
7721 #pragma segment Perl_yylex
7724 Perl_yywarn(pTHX_ char *s)
7726 PL_in_eval |= EVAL_WARNONLY;
7728 PL_in_eval &= ~EVAL_WARNONLY;
7733 Perl_yyerror(pTHX_ char *s)
7736 char *context = NULL;
7740 if (!yychar || (yychar == ';' && !PL_rsfp))
7742 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7743 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7746 The code below is removed for NetWare because it abends/crashes on NetWare
7747 when the script has error such as not having the closing quotes like:
7749 Checking of white spaces is anyway done in NetWare code.
7752 while (isSPACE(*PL_oldoldbufptr))
7755 context = PL_oldoldbufptr;
7756 contlen = PL_bufptr - PL_oldoldbufptr;
7758 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7759 PL_oldbufptr != PL_bufptr) {
7762 The code below is removed for NetWare because it abends/crashes on NetWare
7763 when the script has error such as not having the closing quotes like:
7765 Checking of white spaces is anyway done in NetWare code.
7768 while (isSPACE(*PL_oldbufptr))
7771 context = PL_oldbufptr;
7772 contlen = PL_bufptr - PL_oldbufptr;
7774 else if (yychar > 255)
7775 where = "next token ???";
7776 #ifdef USE_PURE_BISON
7777 /* GNU Bison sets the value -2 */
7778 else if (yychar == -2) {
7780 else if ((yychar & 127) == 127) {
7782 if (PL_lex_state == LEX_NORMAL ||
7783 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7784 where = "at end of line";
7785 else if (PL_lex_inpat)
7786 where = "within pattern";
7788 where = "within string";
7791 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7793 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7794 else if (isPRINT_LC(yychar))
7795 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7797 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7798 where = SvPVX(where_sv);
7800 msg = sv_2mortal(newSVpv(s, 0));
7801 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7802 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7804 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7806 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7807 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7808 Perl_sv_catpvf(aTHX_ msg,
7809 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7810 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7813 if (PL_in_eval & EVAL_WARNONLY)
7814 Perl_warn(aTHX_ "%"SVf, msg);
7817 if (PL_error_count >= 10) {
7818 if (PL_in_eval && SvCUR(ERRSV))
7819 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7820 ERRSV, OutCopFILE(PL_curcop));
7822 Perl_croak(aTHX_ "%s has too many errors.\n",
7823 OutCopFILE(PL_curcop));
7826 PL_in_my_stash = Nullhv;
7830 #pragma segment Main
7834 S_swallow_bom(pTHX_ U8 *s)
7837 slen = SvCUR(PL_linestr);
7841 /* UTF-16 little-endian */
7842 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
7843 Perl_croak(aTHX_ "Unsupported script encoding");
7844 #ifndef PERL_NO_UTF16_FILTER
7845 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7847 if (PL_bufend > (char*)s) {
7851 filter_add(utf16rev_textfilter, NULL);
7852 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7853 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7854 PL_bufend - (char*)s - 1,
7856 Copy(news, s, newlen, U8);
7857 SvCUR_set(PL_linestr, newlen);
7858 PL_bufend = SvPVX(PL_linestr) + newlen;
7859 news[newlen++] = '\0';
7863 Perl_croak(aTHX_ "Unsupported script encoding");
7868 if (s[1] == 0xFF) { /* UTF-16 big-endian */
7869 #ifndef PERL_NO_UTF16_FILTER
7870 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7872 if (PL_bufend > (char *)s) {
7876 filter_add(utf16_textfilter, NULL);
7877 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7878 PL_bufend = (char*)utf16_to_utf8(s, news,
7879 PL_bufend - (char*)s,
7881 Copy(news, s, newlen, U8);
7882 SvCUR_set(PL_linestr, newlen);
7883 PL_bufend = SvPVX(PL_linestr) + newlen;
7884 news[newlen++] = '\0';
7888 Perl_croak(aTHX_ "Unsupported script encoding");
7893 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7894 DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7899 if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */
7900 s[2] == 0xFE && s[3] == 0xFF)
7902 Perl_croak(aTHX_ "Unsupported script encoding");
7910 * Restore a source filter.
7914 restore_rsfp(pTHX_ void *f)
7916 PerlIO *fp = (PerlIO*)f;
7918 if (PL_rsfp == PerlIO_stdin())
7919 PerlIO_clearerr(PL_rsfp);
7920 else if (PL_rsfp && (PL_rsfp != fp))
7921 PerlIO_close(PL_rsfp);
7925 #ifndef PERL_NO_UTF16_FILTER
7927 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7929 I32 count = FILTER_READ(idx+1, sv, maxlen);
7934 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7935 if (!*SvPV_nolen(sv))
7936 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7939 tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7940 sv_usepvn(sv, (char*)tmps, tend - tmps);
7946 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7948 I32 count = FILTER_READ(idx+1, sv, maxlen);
7953 if (!*SvPV_nolen(sv))
7954 /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7957 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7958 tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7959 sv_usepvn(sv, (char*)tmps, tend - tmps);
7966 Returns a pointer to the next character after the parsed
7967 vstring, as well as updating the passed in sv.
7969 Function must be called like
7972 s = scan_vstring(s,sv);
7974 The sv should already be large enough to store the vstring
7975 passed in, for performance reasons.
7980 Perl_scan_vstring(pTHX_ char *s, SV *sv)
7984 if (*pos == 'v') pos++; /* get past 'v' */
7985 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
7988 /* this may not be a v-string if followed by => */
7990 while (next < PL_bufend && isSPACE(*next))
7992 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
7993 /* return string not v-string */
7994 sv_setpvn(sv,(char *)s,pos-s);
7999 if (!isALPHA(*pos)) {
8001 U8 tmpbuf[UTF8_MAXLEN+1];
8004 if (*s == 'v') s++; /* get past 'v' */
8006 sv_setpvn(sv, "", 0);
8011 /* this is atoi() that tolerates underscores */
8014 while (--end >= s) {
8019 rev += (*end - '0') * mult;
8021 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
8022 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
8023 "Integer overflow in decimal number");
8027 if (rev > 0x7FFFFFFF)
8028 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
8030 /* Append native character for the rev point */
8031 tmpend = uvchr_to_utf8(tmpbuf, rev);
8032 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
8033 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
8035 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
8041 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
8045 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);