toke.c

   1 /*    toke.c
   2  *
   3  *    Copyright (c) 1991-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  *   "It all comes from here, the stench and the peril."  --Frodo
  12  */
  13
  14 /*
  15  * This file is the lexer for Perl.  It's closely linked to the
  16  * parser, perly.y.
  17  *
  18  * The main routine is yylex(), which returns the next token.
  19  */
  20
  21 #include "EXTERN.h"
  22 #define PERL_IN_TOKE_C
  23 #include "perl.h"
  24
  25 #define yychar  PL_yychar
  26 #define yylval  PL_yylval
  27
  28 static char ident_too_long[] = "Identifier too long";
  29
  30 static void restore_rsfp(pTHX_ void *f);
  31 #ifndef PERL_NO_UTF16_FILTER
  32 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  33 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  34 #endif
  35
  36 #define XFAKEBRACK 128
  37 #define XENUMMASK 127
  38
  39 #ifdef USE_UTF8_SCRIPTS
  40 #   define UTF (!IN_BYTES)
  41 #else
  42 #   ifdef EBCDIC /* For now 'use utf8' does not affect tokenizer on EBCDIC */
  43 #       define UTF (PL_linestr && DO_UTF8(PL_linestr))
  44 #   else
  45 #       define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
  46 #   endif
  47 #endif
  48
  49 /* In variables named $^X, these are the legal values for X.
  50  * 1999-02-27 mjd-perl-patch@plover.com */
  51 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
  52
  53 /* On MacOS, respect nonbreaking spaces */
  54 #ifdef MACOS_TRADITIONAL
  55 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
  56 #else
  57 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
  58 #endif
  59
  60 /* LEX_* are values for PL_lex_state, the state of the lexer.
  61  * They are arranged oddly so that the guard on the switch statement
  62  * can get by with a single comparison (if the compiler is smart enough).
  63  */
  64
  65 /* #define LEX_NOTPARSING               11 is done in perl.h. */
  66
  67 #define LEX_NORMAL              10
  68 #define LEX_INTERPNORMAL         9
  69 #define LEX_INTERPCASEMOD        8
  70 #define LEX_INTERPPUSH           7
  71 #define LEX_INTERPSTART          6
  72 #define LEX_INTERPEND            5
  73 #define LEX_INTERPENDMAYBE       4
  74 #define LEX_INTERPCONCAT         3
  75 #define LEX_INTERPCONST          2
  76 #define LEX_FORMLINE             1
  77 #define LEX_KNOWNEXT             0
  78
  79 #ifdef ff_next
  80 #undef ff_next
  81 #endif
  82
  83 #ifdef USE_PURE_BISON
  84 #  ifndef YYMAXLEVEL
  85 #    define YYMAXLEVEL 100
  86 #  endif
  87 YYSTYPE* yylval_pointer[YYMAXLEVEL];
  88 int* yychar_pointer[YYMAXLEVEL];
  89 int yyactlevel = -1;
  90 #  undef yylval
  91 #  undef yychar
  92 #  define yylval (*yylval_pointer[yyactlevel])
  93 #  define yychar (*yychar_pointer[yyactlevel])
  94 #  define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
  95 #  undef yylex
  96 #  define yylex()      Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
  97 #endif
  98
  99 #include "keywords.h"
 100
 101 /* CLINE is a macro that ensures PL_copline has a sane value */
 102
 103 #ifdef CLINE
 104 #undef CLINE
 105 #endif
 106 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
 107
 108 /*
 109  * Convenience functions to return different tokens and prime the
 110  * lexer for the next token.  They all take an argument.
 111  *
 112  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
 113  * OPERATOR     : generic operator
 114  * AOPERATOR    : assignment operator
 115  * PREBLOCK     : beginning the block after an if, while, foreach, ...
 116  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
 117  * PREREF       : *EXPR where EXPR is not a simple identifier
 118  * TERM         : expression term
 119  * LOOPX        : loop exiting command (goto, last, dump, etc)
 120  * FTST         : file test operator
 121  * FUN0         : zero-argument function
 122  * FUN1         : not used, except for not, which isn't a UNIOP
 123  * BOop         : bitwise or or xor
 124  * BAop         : bitwise and
 125  * SHop         : shift operator
 126  * PWop         : power operator
 127  * PMop         : pattern-matching operator
 128  * Aop          : addition-level operator
 129  * Mop          : multiplication-level operator
 130  * Eop          : equality-testing operator
 131  * Rop          : relational operator <= != gt
 132  *
 133  * Also see LOP and lop() below.
 134  */
 135
 136 /* Note that REPORT() and REPORT2() will be expressions that supply
 137  * their own trailing comma, not suitable for statements as such. */
 138 #ifdef DEBUGGING /* Serve -DT. */
 139 #   define REPORT(x,retval) tokereport(x,s,(int)retval),
 140 #   define REPORT2(x,retval) tokereport(x,s, yylval.ival),
 141 #else
 142 #   define REPORT(x,retval)
 143 #   define REPORT2(x,retval)
 144 #endif
 145
 146 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
 147 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
 148 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
 149 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
 150 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
 151 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
 152 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
 153 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
 154 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
 155 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
 156 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
 157 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
 158 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
 159 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
 160 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
 161 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
 162 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
 163 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
 164 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
 165 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
 166
 167 /* This bit of chicanery makes a unary function followed by
 168  * a parenthesis into a function with one argument, highest precedence.
 169  */
 170 #define UNI(f) return(yylval.ival = f, \
 171         REPORT("uni",f) \
 172         PL_expect = XTERM, \
 173         PL_bufptr = s, \
 174         PL_last_uni = PL_oldbufptr, \
 175         PL_last_lop_op = f, \
 176         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 177
 178 #define UNIBRACK(f) return(yylval.ival = f, \
 179         REPORT("uni",f) \
 180         PL_bufptr = s, \
 181         PL_last_uni = PL_oldbufptr, \
 182         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 183
 184 /* grandfather return to old style */
 185 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 186
 187 #ifdef DEBUGGING
 188
 189 STATIC void
 190 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
 191 {
 192     DEBUG_T({
 193         SV* report = newSVpv(thing, 0);
 194         Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
 195                 (IV)rv);
 196
 197         if (s - PL_bufptr > 0)
 198             sv_catpvn(report, PL_bufptr, s - PL_bufptr);
 199         else {
 200             if (PL_oldbufptr && *PL_oldbufptr)
 201                 sv_catpv(report, PL_tokenbuf);
 202         }
 203         PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
 204     });
 205 }
 206
 207 #endif
 208
 209 /*
 210  * S_ao
 211  *
 212  * This subroutine detects &&= and ||= and turns an ANDAND or OROR
 213  * into an OP_ANDASSIGN or OP_ORASSIGN
 214  */
 215
 216 STATIC int
 217 S_ao(pTHX_ int toketype)
 218 {
 219     if (*PL_bufptr == '=') {
 220         PL_bufptr++;
 221         if (toketype == ANDAND)
 222             yylval.ival = OP_ANDASSIGN;
 223         else if (toketype == OROR)
 224             yylval.ival = OP_ORASSIGN;
 225         toketype = ASSIGNOP;
 226     }
 227     return toketype;
 228 }
 229
 230 /*
 231  * S_no_op
 232  * When Perl expects an operator and finds something else, no_op
 233  * prints the warning.  It always prints "<something> found where
 234  * operator expected.  It prints "Missing semicolon on previous line?"
 235  * if the surprise occurs at the start of the line.  "do you need to
 236  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 237  * where the compiler doesn't know if foo is a method call or a function.
 238  * It prints "Missing operator before end of line" if there's nothing
 239  * after the missing operator, or "... before <...>" if there is something
 240  * after the missing operator.
 241  */
 242
 243 STATIC void
 244 S_no_op(pTHX_ char *what, char *s)
 245 {
 246     char *oldbp = PL_bufptr;
 247     bool is_first = (PL_oldbufptr == PL_linestart);
 248
 249     if (!s)
 250         s = oldbp;
 251     else
 252         PL_bufptr = s;
 253     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 254     if (is_first)
 255         Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
 256     else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
 257         char *t;
 258         for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
 259         if (t < PL_bufptr && isSPACE(*t))
 260             Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
 261                 t - PL_oldoldbufptr, PL_oldoldbufptr);
 262     }
 263     else {
 264         assert(s >= oldbp);
 265         Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
 266     }
 267     PL_bufptr = oldbp;
 268 }
 269
 270 /*
 271  * S_missingterm
 272  * Complain about missing quote/regexp/heredoc terminator.
 273  * If it's called with (char *)NULL then it cauterizes the line buffer.
 274  * If we're in a delimited string and the delimiter is a control
 275  * character, it's reformatted into a two-char sequence like ^C.
 276  * This is fatal.
 277  */
 278
 279 STATIC void
 280 S_missingterm(pTHX_ char *s)
 281 {
 282     char tmpbuf[3];
 283     char q;
 284     if (s) {
 285         char *nl = strrchr(s,'\n');
 286         if (nl)
 287             *nl = '\0';
 288     }
 289     else if (
 290 #ifdef EBCDIC
 291         iscntrl(PL_multi_close)
 292 #else
 293         PL_multi_close < 32 || PL_multi_close == 127
 294 #endif
 295         ) {
 296         *tmpbuf = '^';
 297         tmpbuf[1] = toCTRL(PL_multi_close);
 298         s = "\\n";
 299         tmpbuf[2] = '\0';
 300         s = tmpbuf;
 301     }
 302     else {
 303         *tmpbuf = PL_multi_close;
 304         tmpbuf[1] = '\0';
 305         s = tmpbuf;
 306     }
 307     q = strchr(s,'"') ? '\'' : '"';
 308     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 309 }
 310
 311 /*
 312  * Perl_deprecate
 313  */
 314
 315 void
 316 Perl_deprecate(pTHX_ char *s)
 317 {
 318     if (ckWARN(WARN_DEPRECATED))
 319         Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
 320 }
 321
 322 /*
 323  * depcom
 324  * Deprecate a comma-less variable list.
 325  */
 326
 327 STATIC void
 328 S_depcom(pTHX)
 329 {
 330     deprecate("comma-less variable list");
 331 }
 332
 333 /*
 334  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 335  * utf16-to-utf8-reversed.
 336  */
 337
 338 #ifdef PERL_CR_FILTER
 339 static void
 340 strip_return(SV *sv)
 341 {
 342     register char *s = SvPVX(sv);
 343     register char *e = s + SvCUR(sv);
 344     /* outer loop optimized to do nothing if there are no CR-LFs */
 345     while (s < e) {
 346         if (*s++ == '\r' && *s == '\n') {
 347             /* hit a CR-LF, need to copy the rest */
 348             register char *d = s - 1;
 349             *d++ = *s++;
 350             while (s < e) {
 351                 if (*s == '\r' && s[1] == '\n')
 352                     s++;
 353                 *d++ = *s++;
 354             }
 355             SvCUR(sv) -= s - d;
 356             return;
 357         }
 358     }
 359 }
 360
 361 STATIC I32
 362 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 363 {
 364     I32 count = FILTER_READ(idx+1, sv, maxlen);
 365     if (count > 0 && !maxlen)
 366         strip_return(sv);
 367     return count;
 368 }
 369 #endif
 370
 371 /*
 372  * Perl_lex_start
 373  * Initialize variables.  Uses the Perl save_stack to save its state (for
 374  * recursive calls to the parser).
 375  */
 376
 377 void
 378 Perl_lex_start(pTHX_ SV *line)
 379 {
 380     char *s;
 381     STRLEN len;
 382
 383     SAVEI32(PL_lex_dojoin);
 384     SAVEI32(PL_lex_brackets);
 385     SAVEI32(PL_lex_casemods);
 386     SAVEI32(PL_lex_starts);
 387     SAVEI32(PL_lex_state);
 388     SAVEVPTR(PL_lex_inpat);
 389     SAVEI32(PL_lex_inwhat);
 390     if (PL_lex_state == LEX_KNOWNEXT) {
 391         I32 toke = PL_nexttoke;
 392         while (--toke >= 0) {
 393             SAVEI32(PL_nexttype[toke]);
 394             SAVEVPTR(PL_nextval[toke]);
 395         }
 396         SAVEI32(PL_nexttoke);
 397     }
 398     SAVECOPLINE(PL_curcop);
 399     SAVEPPTR(PL_bufptr);
 400     SAVEPPTR(PL_bufend);
 401     SAVEPPTR(PL_oldbufptr);
 402     SAVEPPTR(PL_oldoldbufptr);
 403     SAVEPPTR(PL_last_lop);
 404     SAVEPPTR(PL_last_uni);
 405     SAVEPPTR(PL_linestart);
 406     SAVESPTR(PL_linestr);
 407     SAVEPPTR(PL_lex_brackstack);
 408     SAVEPPTR(PL_lex_casestack);
 409     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
 410     SAVESPTR(PL_lex_stuff);
 411     SAVEI32(PL_lex_defer);
 412     SAVEI32(PL_sublex_info.sub_inwhat);
 413     SAVESPTR(PL_lex_repl);
 414     SAVEINT(PL_expect);
 415     SAVEINT(PL_lex_expect);
 416
 417     PL_lex_state = LEX_NORMAL;
 418     PL_lex_defer = 0;
 419     PL_expect = XSTATE;
 420     PL_lex_brackets = 0;
 421     New(899, PL_lex_brackstack, 120, char);
 422     New(899, PL_lex_casestack, 12, char);
 423     SAVEFREEPV(PL_lex_brackstack);
 424     SAVEFREEPV(PL_lex_casestack);
 425     PL_lex_casemods = 0;
 426     *PL_lex_casestack = '\0';
 427     PL_lex_dojoin = 0;
 428     PL_lex_starts = 0;
 429     PL_lex_stuff = Nullsv;
 430     PL_lex_repl = Nullsv;
 431     PL_lex_inpat = 0;
 432     PL_nexttoke = 0;
 433     PL_lex_inwhat = 0;
 434     PL_sublex_info.sub_inwhat = 0;
 435     PL_linestr = line;
 436     if (SvREADONLY(PL_linestr))
 437         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 438     s = SvPV(PL_linestr, len);
 439     if (len && s[len-1] != ';') {
 440         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
 441             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 442         sv_catpvn(PL_linestr, "\n;", 2);
 443     }
 444     SvTEMP_off(PL_linestr);
 445     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 446     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 447     PL_last_lop = PL_last_uni = Nullch;
 448     PL_rsfp = 0;
 449 }
 450
 451 /*
 452  * Perl_lex_end
 453  * Finalizer for lexing operations.  Must be called when the parser is
 454  * done with the lexer.
 455  */
 456
 457 void
 458 Perl_lex_end(pTHX)
 459 {
 460     PL_doextract = FALSE;
 461 }
 462
 463 /*
 464  * S_incline
 465  * This subroutine has nothing to do with tilting, whether at windmills
 466  * or pinball tables.  Its name is short for "increment line".  It
 467  * increments the current line number in CopLINE(PL_curcop) and checks
 468  * to see whether the line starts with a comment of the form
 469  *    # line 500 "foo.pm"
 470  * If so, it sets the current line number and file to the values in the comment.
 471  */
 472
 473 STATIC void
 474 S_incline(pTHX_ char *s)
 475 {
 476     char *t;
 477     char *n;
 478     char *e;
 479     char ch;
 480
 481     CopLINE_inc(PL_curcop);
 482     if (*s++ != '#')
 483         return;
 484     while (SPACE_OR_TAB(*s)) s++;
 485     if (strnEQ(s, "line", 4))
 486         s += 4;
 487     else
 488         return;
 489     if (SPACE_OR_TAB(*s))
 490         s++;
 491     else
 492         return;
 493     while (SPACE_OR_TAB(*s)) s++;
 494     if (!isDIGIT(*s))
 495         return;
 496     n = s;
 497     while (isDIGIT(*s))
 498         s++;
 499     while (SPACE_OR_TAB(*s))
 500         s++;
 501     if (*s == '"' && (t = strchr(s+1, '"'))) {
 502         s++;
 503         e = t + 1;
 504     }
 505     else {
 506         for (t = s; !isSPACE(*t); t++) ;
 507         e = t;
 508     }
 509     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 510         e++;
 511     if (*e != '\n' && *e != '\0')
 512         return;         /* false alarm */
 513
 514     ch = *t;
 515     *t = '\0';
 516     if (t - s > 0) {
 517         CopFILE_free(PL_curcop);
 518         CopFILE_set(PL_curcop, s);
 519     }
 520     *t = ch;
 521     CopLINE_set(PL_curcop, atoi(n)-1);
 522 }
 523
 524 /*
 525  * S_skipspace
 526  * Called to gobble the appropriate amount and type of whitespace.
 527  * Skips comments as well.
 528  */
 529
 530 STATIC char *
 531 S_skipspace(pTHX_ register char *s)
 532 {
 533     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 534         while (s < PL_bufend && SPACE_OR_TAB(*s))
 535             s++;
 536         return s;
 537     }
 538     for (;;) {
 539         STRLEN prevlen;
 540         SSize_t oldprevlen, oldoldprevlen;
 541         SSize_t oldloplen = 0, oldunilen = 0;
 542         while (s < PL_bufend && isSPACE(*s)) {
 543             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
 544                 incline(s);
 545         }
 546
 547         /* comment */
 548         if (s < PL_bufend && *s == '#') {
 549             while (s < PL_bufend && *s != '\n')
 550                 s++;
 551             if (s < PL_bufend) {
 552                 s++;
 553                 if (PL_in_eval && !PL_rsfp) {
 554                     incline(s);
 555                     continue;
 556                 }
 557             }
 558         }
 559
 560         /* only continue to recharge the buffer if we're at the end
 561          * of the buffer, we're not reading from a source filter, and
 562          * we're in normal lexing mode
 563          */
 564         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
 565                 PL_lex_state == LEX_FORMLINE)
 566             return s;
 567
 568         /* try to recharge the buffer */
 569         if ((s = filter_gets(PL_linestr, PL_rsfp,
 570                              (prevlen = SvCUR(PL_linestr)))) == Nullch)
 571         {
 572             /* end of file.  Add on the -p or -n magic */
 573             if (PL_minus_n || PL_minus_p) {
 574                 sv_setpv(PL_linestr,PL_minus_p ?
 575                          ";}continue{print or die qq(-p destination: $!\\n)" :
 576                          "");
 577                 sv_catpv(PL_linestr,";}");
 578                 PL_minus_n = PL_minus_p = 0;
 579             }
 580             else
 581                 sv_setpv(PL_linestr,";");
 582
 583             /* reset variables for next time we lex */
 584             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
 585                 = SvPVX(PL_linestr);
 586             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 587             PL_last_lop = PL_last_uni = Nullch;
 588
 589             /* Close the filehandle.  Could be from -P preprocessor,
 590              * STDIN, or a regular file.  If we were reading code from
 591              * STDIN (because the commandline held no -e or filename)
 592              * then we don't close it, we reset it so the code can
 593              * read from STDIN too.
 594              */
 595
 596             if (PL_preprocess && !PL_in_eval)
 597                 (void)PerlProc_pclose(PL_rsfp);
 598             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
 599                 PerlIO_clearerr(PL_rsfp);
 600             else
 601                 (void)PerlIO_close(PL_rsfp);
 602             PL_rsfp = Nullfp;
 603             return s;
 604         }
 605
 606         /* not at end of file, so we only read another line */
 607         /* make corresponding updates to old pointers, for yyerror() */
 608         oldprevlen = PL_oldbufptr - PL_bufend;
 609         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
 610         if (PL_last_uni)
 611             oldunilen = PL_last_uni - PL_bufend;
 612         if (PL_last_lop)
 613             oldloplen = PL_last_lop - PL_bufend;
 614         PL_linestart = PL_bufptr = s + prevlen;
 615         PL_bufend = s + SvCUR(PL_linestr);
 616         s = PL_bufptr;
 617         PL_oldbufptr = s + oldprevlen;
 618         PL_oldoldbufptr = s + oldoldprevlen;
 619         if (PL_last_uni)
 620             PL_last_uni = s + oldunilen;
 621         if (PL_last_lop)
 622             PL_last_lop = s + oldloplen;
 623         incline(s);
 624
 625         /* debugger active and we're not compiling the debugger code,
 626          * so store the line into the debugger's array of lines
 627          */
 628         if (PERLDB_LINE && PL_curstash != PL_debstash) {
 629             SV *sv = NEWSV(85,0);
 630
 631             sv_upgrade(sv, SVt_PVMG);
 632             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
 633             (void)SvIOK_on(sv);
 634             SvIVX(sv) = 0;
 635             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
 636         }
 637     }
 638 }
 639
 640 /*
 641  * S_check_uni
 642  * Check the unary operators to ensure there's no ambiguity in how they're
 643  * used.  An ambiguous piece of code would be:
 644  *     rand + 5
 645  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
 646  * the +5 is its argument.
 647  */
 648
 649 STATIC void
 650 S_check_uni(pTHX)
 651 {
 652     char *s;
 653     char *t;
 654
 655     if (PL_oldoldbufptr != PL_last_uni)
 656         return;
 657     while (isSPACE(*PL_last_uni))
 658         PL_last_uni++;
 659     for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
 660     if ((t = strchr(s, '(')) && t < PL_bufptr)
 661         return;
 662     if (ckWARN_d(WARN_AMBIGUOUS)){
 663         char ch = *s;
 664         *s = '\0';
 665         Perl_warner(aTHX_ WARN_AMBIGUOUS,
 666                    "Warning: Use of \"%s\" without parens is ambiguous",
 667                    PL_last_uni);
 668         *s = ch;
 669     }
 670 }
 671
 672 /* workaround to replace the UNI() macro with a function.  Only the
 673  * hints/uts.sh file mentions this.  Other comments elsewhere in the
 674  * source indicate Microport Unix might need it too.
 675  */
 676
 677 #ifdef CRIPPLED_CC
 678
 679 #undef UNI
 680 #define UNI(f) return uni(f,s)
 681
 682 STATIC int
 683 S_uni(pTHX_ I32 f, char *s)
 684 {
 685     yylval.ival = f;
 686     PL_expect = XTERM;
 687     PL_bufptr = s;
 688     PL_last_uni = PL_oldbufptr;
 689     PL_last_lop_op = f;
 690     if (*s == '(')
 691         return FUNC1;
 692     s = skipspace(s);
 693     if (*s == '(')
 694         return FUNC1;
 695     else
 696         return UNIOP;
 697 }
 698
 699 #endif /* CRIPPLED_CC */
 700
 701 /*
 702  * LOP : macro to build a list operator.  Its behaviour has been replaced
 703  * with a subroutine, S_lop() for which LOP is just another name.
 704  */
 705
 706 #define LOP(f,x) return lop(f,x,s)
 707
 708 /*
 709  * S_lop
 710  * Build a list operator (or something that might be one).  The rules:
 711  *  - if we have a next token, then it's a list operator [why?]
 712  *  - if the next thing is an opening paren, then it's a function
 713  *  - else it's a list operator
 714  */
 715
 716 STATIC I32
 717 S_lop(pTHX_ I32 f, int x, char *s)
 718 {
 719     yylval.ival = f;
 720     CLINE;
 721     REPORT("lop", f)
 722     PL_expect = x;
 723     PL_bufptr = s;
 724     PL_last_lop = PL_oldbufptr;
 725     PL_last_lop_op = f;
 726     if (PL_nexttoke)
 727         return LSTOP;
 728     if (*s == '(')
 729         return FUNC;
 730     s = skipspace(s);
 731     if (*s == '(')
 732         return FUNC;
 733     else
 734         return LSTOP;
 735 }
 736
 737 /*
 738  * S_force_next
 739  * When the lexer realizes it knows the next token (for instance,
 740  * it is reordering tokens for the parser) then it can call S_force_next
 741  * to know what token to return the next time the lexer is called.  Caller
 742  * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
 743  * handles the token correctly.
 744  */
 745
 746 STATIC void
 747 S_force_next(pTHX_ I32 type)
 748 {
 749     PL_nexttype[PL_nexttoke] = type;
 750     PL_nexttoke++;
 751     if (PL_lex_state != LEX_KNOWNEXT) {
 752         PL_lex_defer = PL_lex_state;
 753         PL_lex_expect = PL_expect;
 754         PL_lex_state = LEX_KNOWNEXT;
 755     }
 756 }
 757
 758 /*
 759  * S_force_word
 760  * When the lexer knows the next thing is a word (for instance, it has
 761  * just seen -> and it knows that the next char is a word char, then
 762  * it calls S_force_word to stick the next word into the PL_next lookahead.
 763  *
 764  * Arguments:
 765  *   char *start : buffer position (must be within PL_linestr)
 766  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
 767  *   int check_keyword : if true, Perl checks to make sure the word isn't
 768  *       a keyword (do this if the word is a label, e.g. goto FOO)
 769  *   int allow_pack : if true, : characters will also be allowed (require,
 770  *       use, etc. do this)
 771  *   int allow_initial_tick : used by the "sub" lexer only.
 772  */
 773
 774 STATIC char *
 775 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
 776 {
 777     register char *s;
 778     STRLEN len;
 779
 780     start = skipspace(start);
 781     s = start;
 782     if (isIDFIRST_lazy_if(s,UTF) ||
 783         (allow_pack && *s == ':') ||
 784         (allow_initial_tick && *s == '\'') )
 785     {
 786         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
 787         if (check_keyword && keyword(PL_tokenbuf, len))
 788             return start;
 789         if (token == METHOD) {
 790             s = skipspace(s);
 791             if (*s == '(')
 792                 PL_expect = XTERM;
 793             else {
 794                 PL_expect = XOPERATOR;
 795             }
 796         }
 797         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
 798         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
 799         force_next(token);
 800     }
 801     return s;
 802 }
 803
 804 /*
 805  * S_force_ident
 806  * Called when the lexer wants $foo *foo &foo etc, but the program
 807  * text only contains the "foo" portion.  The first argument is a pointer
 808  * to the "foo", and the second argument is the type symbol to prefix.
 809  * Forces the next token to be a "WORD".
 810  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
 811  */
 812
 813 STATIC void
 814 S_force_ident(pTHX_ register char *s, int kind)
 815 {
 816     if (s && *s) {
 817         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
 818         PL_nextval[PL_nexttoke].opval = o;
 819         force_next(WORD);
 820         if (kind) {
 821             o->op_private = OPpCONST_ENTERED;
 822             /* XXX see note in pp_entereval() for why we forgo typo
 823                warnings if the symbol must be introduced in an eval.
 824                GSAR 96-10-12 */
 825             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
 826                 kind == '$' ? SVt_PV :
 827                 kind == '@' ? SVt_PVAV :
 828                 kind == '%' ? SVt_PVHV :
 829                               SVt_PVGV
 830                 );
 831         }
 832     }
 833 }
 834
 835 NV
 836 Perl_str_to_version(pTHX_ SV *sv)
 837 {
 838     NV retval = 0.0;
 839     NV nshift = 1.0;
 840     STRLEN len;
 841     char *start = SvPVx(sv,len);
 842     bool utf = SvUTF8(sv) ? TRUE : FALSE;
 843     char *end = start + len;
 844     while (start < end) {
 845         STRLEN skip;
 846         UV n;
 847         if (utf)
 848             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
 849         else {
 850             n = *(U8*)start;
 851             skip = 1;
 852         }
 853         retval += ((NV)n)/nshift;
 854         start += skip;
 855         nshift *= 1000;
 856     }
 857     return retval;
 858 }
 859
 860 /*
 861  * S_force_version
 862  * Forces the next token to be a version number.
 863  * If the next token appears to be an invalid version number, (e.g. "v2b"),
 864  * and if "guessing" is TRUE, then no new token is created (and the caller
 865  * must use an alternative parsing method).
 866  */
 867
 868 STATIC char *
 869 S_force_version(pTHX_ char *s, int guessing)
 870 {
 871     OP *version = Nullop;
 872     char *d;
 873
 874     s = skipspace(s);
 875
 876     d = s;
 877     if (*d == 'v')
 878         d++;
 879     if (isDIGIT(*d)) {
 880         while (isDIGIT(*d) || *d == '_' || *d == '.')
 881             d++;
 882         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
 883             SV *ver;
 884             s = scan_num(s, &yylval);
 885             version = yylval.opval;
 886             ver = cSVOPx(version)->op_sv;
 887             if (SvPOK(ver) && !SvNIOK(ver)) {
 888                 (void)SvUPGRADE(ver, SVt_PVNV);
 889                 SvNVX(ver) = str_to_version(ver);
 890                 SvNOK_on(ver);          /* hint that it is a version */
 891             }
 892         }
 893         else if (guessing)
 894             return s;
 895     }
 896
 897     /* NOTE: The parser sees the package name and the VERSION swapped */
 898     PL_nextval[PL_nexttoke].opval = version;
 899     force_next(WORD);
 900
 901     return s;
 902 }
 903
 904 /*
 905  * S_tokeq
 906  * Tokenize a quoted string passed in as an SV.  It finds the next
 907  * chunk, up to end of string or a backslash.  It may make a new
 908  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
 909  * turns \\ into \.
 910  */
 911
 912 STATIC SV *
 913 S_tokeq(pTHX_ SV *sv)
 914 {
 915     register char *s;
 916     register char *send;
 917     register char *d;
 918     STRLEN len = 0;
 919     SV *pv = sv;
 920
 921     if (!SvLEN(sv))
 922         goto finish;
 923
 924     s = SvPV_force(sv, len);
 925     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
 926         goto finish;
 927     send = s + len;
 928     while (s < send && *s != '\\')
 929         s++;
 930     if (s == send)
 931         goto finish;
 932     d = s;
 933     if ( PL_hints & HINT_NEW_STRING ) {
 934         pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
 935         if (SvUTF8(sv))
 936             SvUTF8_on(pv);
 937     }
 938     while (s < send) {
 939         if (*s == '\\') {
 940             if (s + 1 < send && (s[1] == '\\'))
 941                 s++;            /* all that, just for this */
 942         }
 943         *d++ = *s++;
 944     }
 945     *d = '\0';
 946     SvCUR_set(sv, d - SvPVX(sv));
 947   finish:
 948     if ( PL_hints & HINT_NEW_STRING )
 949        return new_constant(NULL, 0, "q", sv, pv, "q");
 950     return sv;
 951 }
 952
 953 /*
 954  * Now come three functions related to double-quote context,
 955  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
 956  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
 957  * interact with PL_lex_state, and create fake ( ... ) argument lists
 958  * to handle functions and concatenation.
 959  * They assume that whoever calls them will be setting up a fake
 960  * join call, because each subthing puts a ',' after it.  This lets
 961  *   "lower \luPpEr"
 962  * become
 963  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
 964  *
 965  * (I'm not sure whether the spurious commas at the end of lcfirst's
 966  * arguments and join's arguments are created or not).
 967  */
 968
 969 /*
 970  * S_sublex_start
 971  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
 972  *
 973  * Pattern matching will set PL_lex_op to the pattern-matching op to
 974  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
 975  *
 976  * OP_CONST and OP_READLINE are easy--just make the new op and return.
 977  *
 978  * Everything else becomes a FUNC.
 979  *
 980  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
 981  * had an OP_CONST or OP_READLINE).  This just sets us up for a
 982  * call to S_sublex_push().
 983  */
 984
 985 STATIC I32
 986 S_sublex_start(pTHX)
 987 {
 988     register I32 op_type = yylval.ival;
 989
 990     if (op_type == OP_NULL) {
 991         yylval.opval = PL_lex_op;
 992         PL_lex_op = Nullop;
 993         return THING;
 994     }
 995     if (op_type == OP_CONST || op_type == OP_READLINE) {
 996         SV *sv = tokeq(PL_lex_stuff);
 997
 998         if (SvTYPE(sv) == SVt_PVIV) {
 999             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1000             STRLEN len;
1001             char *p;
1002             SV *nsv;
1003
1004             p = SvPV(sv, len);
1005             nsv = newSVpvn(p, len);
1006             if (SvUTF8(sv))
1007                 SvUTF8_on(nsv);
1008             SvREFCNT_dec(sv);
1009             sv = nsv;
1010         }
1011         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1012         PL_lex_stuff = Nullsv;
1013         return THING;
1014     }
1015
1016     PL_sublex_info.super_state = PL_lex_state;
1017     PL_sublex_info.sub_inwhat = op_type;
1018     PL_sublex_info.sub_op = PL_lex_op;
1019     PL_lex_state = LEX_INTERPPUSH;
1020
1021     PL_expect = XTERM;
1022     if (PL_lex_op) {
1023         yylval.opval = PL_lex_op;
1024         PL_lex_op = Nullop;
1025         return PMFUNC;
1026     }
1027     else
1028         return FUNC;
1029 }
1030
1031 /*
1032  * S_sublex_push
1033  * Create a new scope to save the lexing state.  The scope will be
1034  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1035  * to the uc, lc, etc. found before.
1036  * Sets PL_lex_state to LEX_INTERPCONCAT.
1037  */
1038
1039 STATIC I32
1040 S_sublex_push(pTHX)
1041 {
1042     ENTER;
1043
1044     PL_lex_state = PL_sublex_info.super_state;
1045     SAVEI32(PL_lex_dojoin);
1046     SAVEI32(PL_lex_brackets);
1047     SAVEI32(PL_lex_casemods);
1048     SAVEI32(PL_lex_starts);
1049     SAVEI32(PL_lex_state);
1050     SAVEVPTR(PL_lex_inpat);
1051     SAVEI32(PL_lex_inwhat);
1052     SAVECOPLINE(PL_curcop);
1053     SAVEPPTR(PL_bufptr);
1054     SAVEPPTR(PL_bufend);
1055     SAVEPPTR(PL_oldbufptr);
1056     SAVEPPTR(PL_oldoldbufptr);
1057     SAVEPPTR(PL_last_lop);
1058     SAVEPPTR(PL_last_uni);
1059     SAVEPPTR(PL_linestart);
1060     SAVESPTR(PL_linestr);
1061     SAVEPPTR(PL_lex_brackstack);
1062     SAVEPPTR(PL_lex_casestack);
1063
1064     PL_linestr = PL_lex_stuff;
1065     PL_lex_stuff = Nullsv;
1066
1067     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1068         = SvPVX(PL_linestr);
1069     PL_bufend += SvCUR(PL_linestr);
1070     PL_last_lop = PL_last_uni = Nullch;
1071     SAVEFREESV(PL_linestr);
1072
1073     PL_lex_dojoin = FALSE;
1074     PL_lex_brackets = 0;
1075     New(899, PL_lex_brackstack, 120, char);
1076     New(899, PL_lex_casestack, 12, char);
1077     SAVEFREEPV(PL_lex_brackstack);
1078     SAVEFREEPV(PL_lex_casestack);
1079     PL_lex_casemods = 0;
1080     *PL_lex_casestack = '\0';
1081     PL_lex_starts = 0;
1082     PL_lex_state = LEX_INTERPCONCAT;
1083     CopLINE_set(PL_curcop, PL_multi_start);
1084
1085     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1086     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1087         PL_lex_inpat = PL_sublex_info.sub_op;
1088     else
1089         PL_lex_inpat = Nullop;
1090
1091     return '(';
1092 }
1093
1094 /*
1095  * S_sublex_done
1096  * Restores lexer state after a S_sublex_push.
1097  */
1098
1099 STATIC I32
1100 S_sublex_done(pTHX)
1101 {
1102     if (!PL_lex_starts++) {
1103         SV *sv = newSVpvn("",0);
1104         if (SvUTF8(PL_linestr))
1105             SvUTF8_on(sv);
1106         PL_expect = XOPERATOR;
1107         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1108         return THING;
1109     }
1110
1111     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1112         PL_lex_state = LEX_INTERPCASEMOD;
1113         return yylex();
1114     }
1115
1116     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1117     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1118         PL_linestr = PL_lex_repl;
1119         PL_lex_inpat = 0;
1120         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1121         PL_bufend += SvCUR(PL_linestr);
1122         PL_last_lop = PL_last_uni = Nullch;
1123         SAVEFREESV(PL_linestr);
1124         PL_lex_dojoin = FALSE;
1125         PL_lex_brackets = 0;
1126         PL_lex_casemods = 0;
1127         *PL_lex_casestack = '\0';
1128         PL_lex_starts = 0;
1129         if (SvEVALED(PL_lex_repl)) {
1130             PL_lex_state = LEX_INTERPNORMAL;
1131             PL_lex_starts++;
1132             /*  we don't clear PL_lex_repl here, so that we can check later
1133                 whether this is an evalled subst; that means we rely on the
1134                 logic to ensure sublex_done() is called again only via the
1135                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1136         }
1137         else {
1138             PL_lex_state = LEX_INTERPCONCAT;
1139             PL_lex_repl = Nullsv;
1140         }
1141         return ',';
1142     }
1143     else {
1144         LEAVE;
1145         PL_bufend = SvPVX(PL_linestr);
1146         PL_bufend += SvCUR(PL_linestr);
1147         PL_expect = XOPERATOR;
1148         PL_sublex_info.sub_inwhat = 0;
1149         return ')';
1150     }
1151 }
1152
1153 /*
1154   scan_const
1155
1156   Extracts a pattern, double-quoted string, or transliteration.  This
1157   is terrifying code.
1158
1159   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1160   processing a pattern (PL_lex_inpat is true), a transliteration
1161   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1162
1163   Returns a pointer to the character scanned up to. Iff this is
1164   advanced from the start pointer supplied (ie if anything was
1165   successfully parsed), will leave an OP for the substring scanned
1166   in yylval. Caller must intuit reason for not parsing further
1167   by looking at the next characters herself.
1168
1169   In patterns:
1170     backslashes:
1171       double-quoted style: \r and \n
1172       regexp special ones: \D \s
1173       constants: \x3
1174       backrefs: \1 (deprecated in substitution replacements)
1175       case and quoting: \U \Q \E
1176     stops on @ and $, but not for $ as tail anchor
1177
1178   In transliterations:
1179     characters are VERY literal, except for - not at the start or end
1180     of the string, which indicates a range.  scan_const expands the
1181     range to the full set of intermediate characters.
1182
1183   In double-quoted strings:
1184     backslashes:
1185       double-quoted style: \r and \n
1186       constants: \x3
1187       backrefs: \1 (deprecated)
1188       case and quoting: \U \Q \E
1189     stops on @ and $
1190
1191   scan_const does *not* construct ops to handle interpolated strings.
1192   It stops processing as soon as it finds an embedded $ or @ variable
1193   and leaves it to the caller to work out what's going on.
1194
1195   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1196
1197   $ in pattern could be $foo or could be tail anchor.  Assumption:
1198   it's a tail anchor if $ is the last thing in the string, or if it's
1199   followed by one of ")| \n\t"
1200
1201   \1 (backreferences) are turned into $1
1202
1203   The structure of the code is
1204       while (there's a character to process) {
1205           handle transliteration ranges
1206           skip regexp comments
1207           skip # initiated comments in //x patterns
1208           check for embedded @foo
1209           check for embedded scalars
1210           if (backslash) {
1211               leave intact backslashes from leave (below)
1212               deprecate \1 in strings and sub replacements
1213               handle string-changing backslashes \l \U \Q \E, etc.
1214               switch (what was escaped) {
1215                   handle - in a transliteration (becomes a literal -)
1216                   handle \132 octal characters
1217                   handle 0x15 hex characters
1218                   handle \cV (control V)
1219                   handle printf backslashes (\f, \r, \n, etc)
1220               } (end switch)
1221           } (end if backslash)
1222     } (end while character to read)
1223
1224 */
1225
1226 STATIC char *
1227 S_scan_const(pTHX_ char *start)
1228 {
1229     register char *send = PL_bufend;            /* end of the constant */
1230     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
1231     register char *s = start;                   /* start of the constant */
1232     register char *d = SvPVX(sv);               /* destination for copies */
1233     bool dorange = FALSE;                       /* are we in a translit range? */
1234     bool didrange = FALSE;                      /* did we just finish a range? */
1235     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1236     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1237     UV uv;
1238
1239     const char *leaveit =       /* set of acceptably-backslashed characters */
1240         PL_lex_inpat
1241             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1242             : "";
1243
1244     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1245         /* If we are doing a trans and we know we want UTF8 set expectation */
1246         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1247         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1248     }
1249
1250
1251     while (s < send || dorange) {
1252         /* get transliterations out of the way (they're most literal) */
1253         if (PL_lex_inwhat == OP_TRANS) {
1254             /* expand a range A-Z to the full set of characters.  AIE! */
1255             if (dorange) {
1256                 I32 i;                          /* current expanded character */
1257                 I32 min;                        /* first character in range */
1258                 I32 max;                        /* last character in range */
1259
1260                 if (has_utf8) {
1261                     char *c = (char*)utf8_hop((U8*)d, -1);
1262                     char *e = d++;
1263                     while (e-- > c)
1264                         *(e + 1) = *e;
1265                     *c = (char)UTF_TO_NATIVE(0xff);
1266                     /* mark the range as done, and continue */
1267                     dorange = FALSE;
1268                     didrange = TRUE;
1269                     continue;
1270                 }
1271
1272                 i = d - SvPVX(sv);              /* remember current offset */
1273                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1274                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1275                 d -= 2;                         /* eat the first char and the - */
1276
1277                 min = (U8)*d;                   /* first char in range */
1278                 max = (U8)d[1];                 /* last char in range  */
1279
1280                 if (min > max) {
1281                     Perl_croak(aTHX_
1282                                "Invalid [] range \"%c-%c\" in transliteration operator",
1283                                (char)min, (char)max);
1284                 }
1285
1286 #ifdef EBCDIC
1287                 if ((isLOWER(min) && isLOWER(max)) ||
1288                     (isUPPER(min) && isUPPER(max))) {
1289                     if (isLOWER(min)) {
1290                         for (i = min; i <= max; i++)
1291                             if (isLOWER(i))
1292                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1293                     } else {
1294                         for (i = min; i <= max; i++)
1295                             if (isUPPER(i))
1296                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1297                     }
1298                 }
1299                 else
1300 #endif
1301                     for (i = min; i <= max; i++)
1302                         *d++ = i;
1303
1304                 /* mark the range as done, and continue */
1305                 dorange = FALSE;
1306                 didrange = TRUE;
1307                 continue;
1308             }
1309
1310             /* range begins (ignore - as first or last char) */
1311             else if (*s == '-' && s+1 < send  && s != start) {
1312                 if (didrange) {
1313                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1314                 }
1315                 if (has_utf8) {
1316                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1317                     s++;
1318                     continue;
1319                 }
1320                 dorange = TRUE;
1321                 s++;
1322             }
1323             else {
1324                 didrange = FALSE;
1325             }
1326         }
1327
1328         /* if we get here, we're not doing a transliteration */
1329
1330         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1331            except for the last char, which will be done separately. */
1332         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1333             if (s[2] == '#') {
1334                 while (s < send && *s != ')')
1335                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1336             }
1337             else if (s[2] == '{' /* This should match regcomp.c */
1338                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1339             {
1340                 I32 count = 1;
1341                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1342                 char c;
1343
1344                 while (count && (c = *regparse)) {
1345                     if (c == '\\' && regparse[1])
1346                         regparse++;
1347                     else if (c == '{')
1348                         count++;
1349                     else if (c == '}')
1350                         count--;
1351                     regparse++;
1352                 }
1353                 if (*regparse != ')') {
1354                     regparse--;         /* Leave one char for continuation. */
1355                     yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1356                 }
1357                 while (s < regparse)
1358                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1359             }
1360         }
1361
1362         /* likewise skip #-initiated comments in //x patterns */
1363         else if (*s == '#' && PL_lex_inpat &&
1364           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1365             while (s+1 < send && *s != '\n')
1366                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1367         }
1368
1369         /* check for embedded arrays
1370            (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
1371            */
1372         else if (*s == '@' && s[1]
1373                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1374             break;
1375
1376         /* check for embedded scalars.  only stop if we're sure it's a
1377            variable.
1378         */
1379         else if (*s == '$') {
1380             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1381                 break;
1382             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1383                 break;          /* in regexp, $ might be tail anchor */
1384         }
1385
1386         /* End of else if chain - OP_TRANS rejoin rest */
1387
1388         /* backslashes */
1389         if (*s == '\\' && s+1 < send) {
1390             s++;
1391
1392             /* some backslashes we leave behind */
1393             if (*leaveit && *s && strchr(leaveit, *s)) {
1394                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1395                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1396                 continue;
1397             }
1398
1399             /* deprecate \1 in strings and substitution replacements */
1400             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1401                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1402             {
1403                 if (ckWARN(WARN_SYNTAX))
1404                     Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1405                 *--s = '$';
1406                 break;
1407             }
1408
1409             /* string-change backslash escapes */
1410             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1411                 --s;
1412                 break;
1413             }
1414
1415             /* if we get here, it's either a quoted -, or a digit */
1416             switch (*s) {
1417
1418             /* quoted - in transliterations */
1419             case '-':
1420                 if (PL_lex_inwhat == OP_TRANS) {
1421                     *d++ = *s++;
1422                     continue;
1423                 }
1424                 /* FALL THROUGH */
1425             default:
1426                 {
1427                     if (ckWARN(WARN_MISC) &&
1428                         isALNUM(*s) &&
1429                         *s != '_')
1430                         Perl_warner(aTHX_ WARN_MISC,
1431                                "Unrecognized escape \\%c passed through",
1432                                *s);
1433                     /* default action is to copy the quoted character */
1434                     goto default_action;
1435                 }
1436
1437             /* \132 indicates an octal constant */
1438             case '0': case '1': case '2': case '3':
1439             case '4': case '5': case '6': case '7':
1440                 {
1441                     I32 flags = 0;
1442                     STRLEN len = 3;
1443                     uv = grok_oct(s, &len, &flags, NULL);
1444                     s += len;
1445                 }
1446                 goto NUM_ESCAPE_INSERT;
1447
1448             /* \x24 indicates a hex constant */
1449             case 'x':
1450                 ++s;
1451                 if (*s == '{') {
1452                     char* e = strchr(s, '}');
1453                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1454                       PERL_SCAN_DISALLOW_PREFIX;
1455                     STRLEN len;
1456
1457                     ++s;
1458                     if (!e) {
1459                         yyerror("Missing right brace on \\x{}");
1460                         continue;
1461                     }
1462                     len = e - s;
1463                     uv = grok_hex(s, &len, &flags, NULL);
1464                     s = e + 1;
1465                 }
1466                 else {
1467                     {
1468                         STRLEN len = 2;
1469                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1470                         uv = grok_hex(s, &len, &flags, NULL);
1471                         s += len;
1472                     }
1473                 }
1474
1475               NUM_ESCAPE_INSERT:
1476                 /* Insert oct or hex escaped character.
1477                  * There will always enough room in sv since such
1478                  * escapes will be longer than any UTF-8 sequence
1479                  * they can end up as. */
1480
1481                 /* We need to map to chars to ASCII before doing the tests
1482                    to cover EBCDIC
1483                 */
1484                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1485                     if (!has_utf8 && uv > 255) {
1486                         /* Might need to recode whatever we have
1487                          * accumulated so far if it contains any
1488                          * hibit chars.
1489                          *
1490                          * (Can't we keep track of that and avoid
1491                          *  this rescan? --jhi)
1492                          */
1493                         int hicount = 0;
1494                         U8 *c;
1495                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1496                             if (!NATIVE_IS_INVARIANT(*c)) {
1497                                 hicount++;
1498                             }
1499                         }
1500                         if (hicount) {
1501                             STRLEN offset = d - SvPVX(sv);
1502                             U8 *src, *dst;
1503                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1504                             src = (U8 *)d - 1;
1505                             dst = src+hicount;
1506                             d  += hicount;
1507                             while (src >= (U8 *)SvPVX(sv)) {
1508                                 if (!NATIVE_IS_INVARIANT(*src)) {
1509                                     U8 ch = NATIVE_TO_ASCII(*src);
1510                                     *dst-- = UTF8_EIGHT_BIT_LO(ch);
1511                                     *dst-- = UTF8_EIGHT_BIT_HI(ch);
1512                                 }
1513                                 else {
1514                                     *dst-- = *src;
1515                                 }
1516                                 src--;
1517                             }
1518                         }
1519                     }
1520
1521                     if (has_utf8 || uv > 255) {
1522                         d = (char*)uvchr_to_utf8((U8*)d, uv);
1523                         has_utf8 = TRUE;
1524                         if (PL_lex_inwhat == OP_TRANS &&
1525                             PL_sublex_info.sub_op) {
1526                             PL_sublex_info.sub_op->op_private |=
1527                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
1528                                              : OPpTRANS_TO_UTF);
1529                         }
1530                     }
1531                     else {
1532                         *d++ = (char)uv;
1533                     }
1534                 }
1535                 else {
1536                     *d++ = (char) uv;
1537                 }
1538                 continue;
1539
1540             /* \N{LATIN SMALL LETTER A} is a named character */
1541             case 'N':
1542                 ++s;
1543                 if (*s == '{') {
1544                     char* e = strchr(s, '}');
1545                     SV *res;
1546                     STRLEN len;
1547                     char *str;
1548
1549                     if (!e) {
1550                         yyerror("Missing right brace on \\N{}");
1551                         e = s - 1;
1552                         goto cont_scan;
1553                     }
1554                     res = newSVpvn(s + 1, e - s - 1);
1555                     res = new_constant( Nullch, 0, "charnames",
1556                                         res, Nullsv, "\\N{...}" );
1557                     if (has_utf8)
1558                         sv_utf8_upgrade(res);
1559                     str = SvPV(res,len);
1560                     if (!has_utf8 && SvUTF8(res)) {
1561                         char *ostart = SvPVX(sv);
1562                         SvCUR_set(sv, d - ostart);
1563                         SvPOK_on(sv);
1564                         *d = '\0';
1565                         sv_utf8_upgrade(sv);
1566                         /* this just broke our allocation above... */
1567                         SvGROW(sv, send - start);
1568                         d = SvPVX(sv) + SvCUR(sv);
1569                         has_utf8 = TRUE;
1570                     }
1571                     if (len > e - s + 4) { /* I _guess_ 4 is \N{} --jhi */
1572                         char *odest = SvPVX(sv);
1573
1574                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1575                         d = SvPVX(sv) + (d - odest);
1576                     }
1577                     Copy(str, d, len, char);
1578                     d += len;
1579                     SvREFCNT_dec(res);
1580                   cont_scan:
1581                     s = e + 1;
1582                 }
1583                 else
1584                     yyerror("Missing braces on \\N{}");
1585                 continue;
1586
1587             /* \c is a control character */
1588             case 'c':
1589                 s++;
1590                 {
1591                     U8 c = *s++;
1592 #ifdef EBCDIC
1593                     if (isLOWER(c))
1594                         c = toUPPER(c);
1595 #endif
1596                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1597                 }
1598                 continue;
1599
1600             /* printf-style backslashes, formfeeds, newlines, etc */
1601             case 'b':
1602                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1603                 break;
1604             case 'n':
1605                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1606                 break;
1607             case 'r':
1608                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1609                 break;
1610             case 'f':
1611                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1612                 break;
1613             case 't':
1614                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1615                 break;
1616             case 'e':
1617                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1618                 break;
1619             case 'a':
1620                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1621                 break;
1622             } /* end switch */
1623
1624             s++;
1625             continue;
1626         } /* end if (backslash) */
1627
1628     default_action:
1629         /* If we started with encoded form, or already know we want it
1630            and then encode the next character */
1631         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1632             STRLEN len  = 1;
1633             UV uv       = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1634             STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1635             s += len;
1636             if (need > len) {
1637                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1638                 STRLEN off = d - SvPVX(sv);
1639                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1640             }
1641             d = (char*)uvchr_to_utf8((U8*)d, uv);
1642             has_utf8 = TRUE;
1643         }
1644         else {
1645             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1646         }
1647     } /* while loop to process each character */
1648
1649     /* terminate the string and set up the sv */
1650     *d = '\0';
1651     SvCUR_set(sv, d - SvPVX(sv));
1652     if (SvCUR(sv) >= SvLEN(sv))
1653       Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1654
1655     SvPOK_on(sv);
1656     if (PL_encoding && !has_utf8) {
1657         Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
1658         has_utf8 = TRUE;
1659     }
1660     if (has_utf8) {
1661         SvUTF8_on(sv);
1662         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1663                 PL_sublex_info.sub_op->op_private |=
1664                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1665         }
1666     }
1667
1668     /* shrink the sv if we allocated more than we used */
1669     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1670         SvLEN_set(sv, SvCUR(sv) + 1);
1671         Renew(SvPVX(sv), SvLEN(sv), char);
1672     }
1673
1674     /* return the substring (via yylval) only if we parsed anything */
1675     if (s > PL_bufptr) {
1676         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1677             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1678                               sv, Nullsv,
1679                               ( PL_lex_inwhat == OP_TRANS
1680                                 ? "tr"
1681                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1682                                     ? "s"
1683                                     : "qq")));
1684         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1685     } else
1686         SvREFCNT_dec(sv);
1687     return s;
1688 }
1689
1690 /* S_intuit_more
1691  * Returns TRUE if there's more to the expression (e.g., a subscript),
1692  * FALSE otherwise.
1693  *
1694  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1695  *
1696  * ->[ and ->{ return TRUE
1697  * { and [ outside a pattern are always subscripts, so return TRUE
1698  * if we're outside a pattern and it's not { or [, then return FALSE
1699  * if we're in a pattern and the first char is a {
1700  *   {4,5} (any digits around the comma) returns FALSE
1701  * if we're in a pattern and the first char is a [
1702  *   [] returns FALSE
1703  *   [SOMETHING] has a funky algorithm to decide whether it's a
1704  *      character class or not.  It has to deal with things like
1705  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1706  * anything else returns TRUE
1707  */
1708
1709 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1710
1711 STATIC int
1712 S_intuit_more(pTHX_ register char *s)
1713 {
1714     if (PL_lex_brackets)
1715         return TRUE;
1716     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1717         return TRUE;
1718     if (*s != '{' && *s != '[')
1719         return FALSE;
1720     if (!PL_lex_inpat)
1721         return TRUE;
1722
1723     /* In a pattern, so maybe we have {n,m}. */
1724     if (*s == '{') {
1725         s++;
1726         if (!isDIGIT(*s))
1727             return TRUE;
1728         while (isDIGIT(*s))
1729             s++;
1730         if (*s == ',')
1731             s++;
1732         while (isDIGIT(*s))
1733             s++;
1734         if (*s == '}')
1735             return FALSE;
1736         return TRUE;
1737
1738     }
1739
1740     /* On the other hand, maybe we have a character class */
1741
1742     s++;
1743     if (*s == ']' || *s == '^')
1744         return FALSE;
1745     else {
1746         /* this is terrifying, and it works */
1747         int weight = 2;         /* let's weigh the evidence */
1748         char seen[256];
1749         unsigned char un_char = 255, last_un_char;
1750         char *send = strchr(s,']');
1751         char tmpbuf[sizeof PL_tokenbuf * 4];
1752
1753         if (!send)              /* has to be an expression */
1754             return TRUE;
1755
1756         Zero(seen,256,char);
1757         if (*s == '$')
1758             weight -= 3;
1759         else if (isDIGIT(*s)) {
1760             if (s[1] != ']') {
1761                 if (isDIGIT(s[1]) && s[2] == ']')
1762                     weight -= 10;
1763             }
1764             else
1765                 weight -= 100;
1766         }
1767         for (; s < send; s++) {
1768             last_un_char = un_char;
1769             un_char = (unsigned char)*s;
1770             switch (*s) {
1771             case '@':
1772             case '&':
1773             case '$':
1774                 weight -= seen[un_char] * 10;
1775                 if (isALNUM_lazy_if(s+1,UTF)) {
1776                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1777                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1778                         weight -= 100;
1779                     else
1780                         weight -= 10;
1781                 }
1782                 else if (*s == '$' && s[1] &&
1783                   strchr("[#!%*<>()-=",s[1])) {
1784                     if (/*{*/ strchr("])} =",s[2]))
1785                         weight -= 10;
1786                     else
1787                         weight -= 1;
1788                 }
1789                 break;
1790             case '\\':
1791                 un_char = 254;
1792                 if (s[1]) {
1793                     if (strchr("wds]",s[1]))
1794                         weight += 100;
1795                     else if (seen['\''] || seen['"'])
1796                         weight += 1;
1797                     else if (strchr("rnftbxcav",s[1]))
1798                         weight += 40;
1799                     else if (isDIGIT(s[1])) {
1800                         weight += 40;
1801                         while (s[1] && isDIGIT(s[1]))
1802                             s++;
1803                     }
1804                 }
1805                 else
1806                     weight += 100;
1807                 break;
1808             case '-':
1809                 if (s[1] == '\\')
1810                     weight += 50;
1811                 if (strchr("aA01! ",last_un_char))
1812                     weight += 30;
1813                 if (strchr("zZ79~",s[1]))
1814                     weight += 30;
1815                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1816                     weight -= 5;        /* cope with negative subscript */
1817                 break;
1818             default:
1819                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1820                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1821                     char *d = tmpbuf;
1822                     while (isALPHA(*s))
1823                         *d++ = *s++;
1824                     *d = '\0';
1825                     if (keyword(tmpbuf, d - tmpbuf))
1826                         weight -= 150;
1827                 }
1828                 if (un_char == last_un_char + 1)
1829                     weight += 5;
1830                 weight -= seen[un_char];
1831                 break;
1832             }
1833             seen[un_char]++;
1834         }
1835         if (weight >= 0)        /* probably a character class */
1836             return FALSE;
1837     }
1838
1839     return TRUE;
1840 }
1841
1842 /*
1843  * S_intuit_method
1844  *
1845  * Does all the checking to disambiguate
1846  *   foo bar
1847  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
1848  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1849  *
1850  * First argument is the stuff after the first token, e.g. "bar".
1851  *
1852  * Not a method if bar is a filehandle.
1853  * Not a method if foo is a subroutine prototyped to take a filehandle.
1854  * Not a method if it's really "Foo $bar"
1855  * Method if it's "foo $bar"
1856  * Not a method if it's really "print foo $bar"
1857  * Method if it's really "foo package::" (interpreted as package->foo)
1858  * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1859  * Not a method if bar is a filehandle or package, but is quoted with
1860  *   =>
1861  */
1862
1863 STATIC int
1864 S_intuit_method(pTHX_ char *start, GV *gv)
1865 {
1866     char *s = start + (*start == '$');
1867     char tmpbuf[sizeof PL_tokenbuf];
1868     STRLEN len;
1869     GV* indirgv;
1870
1871     if (gv) {
1872         CV *cv;
1873         if (GvIO(gv))
1874             return 0;
1875         if ((cv = GvCVu(gv))) {
1876             char *proto = SvPVX(cv);
1877             if (proto) {
1878                 if (*proto == ';')
1879                     proto++;
1880                 if (*proto == '*')
1881                     return 0;
1882             }
1883         } else
1884             gv = 0;
1885     }
1886     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1887     /* start is the beginning of the possible filehandle/object,
1888      * and s is the end of it
1889      * tmpbuf is a copy of it
1890      */
1891
1892     if (*start == '$') {
1893         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1894             return 0;
1895         s = skipspace(s);
1896         PL_bufptr = start;
1897         PL_expect = XREF;
1898         return *s == '(' ? FUNCMETH : METHOD;
1899     }
1900     if (!keyword(tmpbuf, len)) {
1901         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1902             len -= 2;
1903             tmpbuf[len] = '\0';
1904             goto bare_package;
1905         }
1906         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1907         if (indirgv && GvCVu(indirgv))
1908             return 0;
1909         /* filehandle or package name makes it a method */
1910         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1911             s = skipspace(s);
1912             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1913                 return 0;       /* no assumptions -- "=>" quotes bearword */
1914       bare_package:
1915             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1916                                                    newSVpvn(tmpbuf,len));
1917             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1918             PL_expect = XTERM;
1919             force_next(WORD);
1920             PL_bufptr = s;
1921             return *s == '(' ? FUNCMETH : METHOD;
1922         }
1923     }
1924     return 0;
1925 }
1926
1927 /*
1928  * S_incl_perldb
1929  * Return a string of Perl code to load the debugger.  If PERL5DB
1930  * is set, it will return the contents of that, otherwise a
1931  * compile-time require of perl5db.pl.
1932  */
1933
1934 STATIC char*
1935 S_incl_perldb(pTHX)
1936 {
1937     if (PL_perldb) {
1938         char *pdb = PerlEnv_getenv("PERL5DB");
1939
1940         if (pdb)
1941             return pdb;
1942         SETERRNO(0,SS$_NORMAL);
1943         return "BEGIN { require 'perl5db.pl' }";
1944     }
1945     return "";
1946 }
1947
1948
1949 /* Encoded script support. filter_add() effectively inserts a
1950  * 'pre-processing' function into the current source input stream.
1951  * Note that the filter function only applies to the current source file
1952  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1953  *
1954  * The datasv parameter (which may be NULL) can be used to pass
1955  * private data to this instance of the filter. The filter function
1956  * can recover the SV using the FILTER_DATA macro and use it to
1957  * store private buffers and state information.
1958  *
1959  * The supplied datasv parameter is upgraded to a PVIO type
1960  * and the IoDIRP/IoANY field is used to store the function pointer,
1961  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1962  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1963  * private use must be set using malloc'd pointers.
1964  */
1965
1966 SV *
1967 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1968 {
1969     if (!funcp)
1970         return Nullsv;
1971
1972     if (!PL_rsfp_filters)
1973         PL_rsfp_filters = newAV();
1974     if (!datasv)
1975         datasv = NEWSV(255,0);
1976     if (!SvUPGRADE(datasv, SVt_PVIO))
1977         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1978     IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1979     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1980     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1981                           (void*)funcp, SvPV_nolen(datasv)));
1982     av_unshift(PL_rsfp_filters, 1);
1983     av_store(PL_rsfp_filters, 0, datasv) ;
1984     return(datasv);
1985 }
1986
1987
1988 /* Delete most recently added instance of this filter function. */
1989 void
1990 Perl_filter_del(pTHX_ filter_t funcp)
1991 {
1992     SV *datasv;
1993     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
1994     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1995         return;
1996     /* if filter is on top of stack (usual case) just pop it off */
1997     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1998     if (IoANY(datasv) == (void *)funcp) {
1999         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2000         IoANY(datasv) = (void *)NULL;
2001         sv_free(av_pop(PL_rsfp_filters));
2002
2003         return;
2004     }
2005     /* we need to search for the correct entry and clear it     */
2006     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2007 }
2008
2009
2010 /* Invoke the n'th filter function for the current rsfp.         */
2011 I32
2012 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2013
2014
2015                         /* 0 = read one text line */
2016 {
2017     filter_t funcp;
2018     SV *datasv = NULL;
2019
2020     if (!PL_rsfp_filters)
2021         return -1;
2022     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
2023         /* Provide a default input filter to make life easy.    */
2024         /* Note that we append to the line. This is handy.      */
2025         DEBUG_P(PerlIO_printf(Perl_debug_log,
2026                               "filter_read %d: from rsfp\n", idx));
2027         if (maxlen) {
2028             /* Want a block */
2029             int len ;
2030             int old_len = SvCUR(buf_sv) ;
2031
2032             /* ensure buf_sv is large enough */
2033             SvGROW(buf_sv, old_len + maxlen) ;
2034             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2035                 if (PerlIO_error(PL_rsfp))
2036                     return -1;          /* error */
2037                 else
2038                     return 0 ;          /* end of file */
2039             }
2040             SvCUR_set(buf_sv, old_len + len) ;
2041         } else {
2042             /* Want a line */
2043             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2044                 if (PerlIO_error(PL_rsfp))
2045                     return -1;          /* error */
2046                 else
2047                     return 0 ;          /* end of file */
2048             }
2049         }
2050         return SvCUR(buf_sv);
2051     }
2052     /* Skip this filter slot if filter has been deleted */
2053     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2054         DEBUG_P(PerlIO_printf(Perl_debug_log,
2055                               "filter_read %d: skipped (filter deleted)\n",
2056                               idx));
2057         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2058     }
2059     /* Get function pointer hidden within datasv        */
2060     funcp = (filter_t)IoANY(datasv);
2061     DEBUG_P(PerlIO_printf(Perl_debug_log,
2062                           "filter_read %d: via function %p (%s)\n",
2063                           idx, (void*)funcp, SvPV_nolen(datasv)));
2064     /* Call function. The function is expected to       */
2065     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2066     /* Return: <0:error, =0:eof, >0:not eof             */
2067     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2068 }
2069
2070 STATIC char *
2071 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2072 {
2073 #ifdef PERL_CR_FILTER
2074     if (!PL_rsfp_filters) {
2075         filter_add(S_cr_textfilter,NULL);
2076     }
2077 #endif
2078     if (PL_rsfp_filters) {
2079
2080         if (!append)
2081             SvCUR_set(sv, 0);   /* start with empty line        */
2082         if (FILTER_READ(0, sv, 0) > 0)
2083             return ( SvPVX(sv) ) ;
2084         else
2085             return Nullch ;
2086     }
2087     else
2088         return (sv_gets(sv, fp, append));
2089 }
2090
2091 STATIC HV *
2092 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2093 {
2094     GV *gv;
2095
2096     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2097         return PL_curstash;
2098
2099     if (len > 2 &&
2100         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2101         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2102     {
2103         return GvHV(gv);                        /* Foo:: */
2104     }
2105
2106     /* use constant CLASS => 'MyClass' */
2107     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2108         SV *sv;
2109         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2110             pkgname = SvPV_nolen(sv);
2111         }
2112     }
2113
2114     return gv_stashpv(pkgname, FALSE);
2115 }
2116
2117 #ifdef DEBUGGING
2118     static char* exp_name[] =
2119         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2120           "ATTRTERM", "TERMBLOCK"
2121         };
2122 #endif
2123
2124 /*
2125   yylex
2126
2127   Works out what to call the token just pulled out of the input
2128   stream.  The yacc parser takes care of taking the ops we return and
2129   stitching them into a tree.
2130
2131   Returns:
2132     PRIVATEREF
2133
2134   Structure:
2135       if read an identifier
2136           if we're in a my declaration
2137               croak if they tried to say my($foo::bar)
2138               build the ops for a my() declaration
2139           if it's an access to a my() variable
2140               are we in a sort block?
2141                   croak if my($a); $a <=> $b
2142               build ops for access to a my() variable
2143           if in a dq string, and they've said @foo and we can't find @foo
2144               croak
2145           build ops for a bareword
2146       if we already built the token before, use it.
2147 */
2148
2149 #ifdef USE_PURE_BISON
2150 int
2151 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2152 {
2153     int r;
2154
2155     yyactlevel++;
2156     yylval_pointer[yyactlevel] = lvalp;
2157     yychar_pointer[yyactlevel] = lcharp;
2158     if (yyactlevel >= YYMAXLEVEL)
2159         Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2160
2161     r = Perl_yylex(aTHX);
2162
2163     if (yyactlevel > 0)
2164        yyactlevel--;
2165
2166     return r;
2167 }
2168 #endif
2169
2170 #ifdef __SC__
2171 #pragma segment Perl_yylex
2172 #endif
2173 int
2174 Perl_yylex(pTHX)
2175 {
2176     register char *s;
2177     register char *d;
2178     register I32 tmp;
2179     STRLEN len;
2180     GV *gv = Nullgv;
2181     GV **gvp = 0;
2182     bool bof = FALSE;
2183
2184     /* check if there's an identifier for us to look at */
2185     if (PL_pending_ident)
2186         return S_pending_ident(aTHX);
2187
2188     /* no identifier pending identification */
2189
2190     switch (PL_lex_state) {
2191 #ifdef COMMENTARY
2192     case LEX_NORMAL:            /* Some compilers will produce faster */
2193     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2194         break;
2195 #endif
2196
2197     /* when we've already built the next token, just pull it out of the queue */
2198     case LEX_KNOWNEXT:
2199         PL_nexttoke--;
2200         yylval = PL_nextval[PL_nexttoke];
2201         if (!PL_nexttoke) {
2202             PL_lex_state = PL_lex_defer;
2203             PL_expect = PL_lex_expect;
2204             PL_lex_defer = LEX_NORMAL;
2205         }
2206         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2207               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2208               (IV)PL_nexttype[PL_nexttoke]); });
2209
2210         return(PL_nexttype[PL_nexttoke]);
2211
2212     /* interpolated case modifiers like \L \U, including \Q and \E.
2213        when we get here, PL_bufptr is at the \
2214     */
2215     case LEX_INTERPCASEMOD:
2216 #ifdef DEBUGGING
2217         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2218             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2219 #endif
2220         /* handle \E or end of string */
2221         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2222             char oldmod;
2223
2224             /* if at a \E */
2225             if (PL_lex_casemods) {
2226                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2227                 PL_lex_casestack[PL_lex_casemods] = '\0';
2228
2229                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2230                     PL_bufptr += 2;
2231                     PL_lex_state = LEX_INTERPCONCAT;
2232                 }
2233                 return ')';
2234             }
2235             if (PL_bufptr != PL_bufend)
2236                 PL_bufptr += 2;
2237             PL_lex_state = LEX_INTERPCONCAT;
2238             return yylex();
2239         }
2240         else {
2241             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2242               "### Saw case modifier at '%s'\n", PL_bufptr); });
2243             s = PL_bufptr + 1;
2244             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2245                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
2246             if (strchr("LU", *s) &&
2247                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2248             {
2249                 PL_lex_casestack[--PL_lex_casemods] = '\0';
2250                 return ')';
2251             }
2252             if (PL_lex_casemods > 10) {
2253                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2254                 if (newlb != PL_lex_casestack) {
2255                     SAVEFREEPV(newlb);
2256                     PL_lex_casestack = newlb;
2257                 }
2258             }
2259             PL_lex_casestack[PL_lex_casemods++] = *s;
2260             PL_lex_casestack[PL_lex_casemods] = '\0';
2261             PL_lex_state = LEX_INTERPCONCAT;
2262             PL_nextval[PL_nexttoke].ival = 0;
2263             force_next('(');
2264             if (*s == 'l')
2265                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2266             else if (*s == 'u')
2267                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2268             else if (*s == 'L')
2269                 PL_nextval[PL_nexttoke].ival = OP_LC;
2270             else if (*s == 'U')
2271                 PL_nextval[PL_nexttoke].ival = OP_UC;
2272             else if (*s == 'Q')
2273                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2274             else
2275                 Perl_croak(aTHX_ "panic: yylex");
2276             PL_bufptr = s + 1;
2277             force_next(FUNC);
2278             if (PL_lex_starts) {
2279                 s = PL_bufptr;
2280                 PL_lex_starts = 0;
2281                 Aop(OP_CONCAT);
2282             }
2283             else
2284                 return yylex();
2285         }
2286
2287     case LEX_INTERPPUSH:
2288         return sublex_push();
2289
2290     case LEX_INTERPSTART:
2291         if (PL_bufptr == PL_bufend)
2292             return sublex_done();
2293         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2294               "### Interpolated variable at '%s'\n", PL_bufptr); });
2295         PL_expect = XTERM;
2296         PL_lex_dojoin = (*PL_bufptr == '@');
2297         PL_lex_state = LEX_INTERPNORMAL;
2298         if (PL_lex_dojoin) {
2299             PL_nextval[PL_nexttoke].ival = 0;
2300             force_next(',');
2301 #ifdef USE_5005THREADS
2302             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2303             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2304             force_next(PRIVATEREF);
2305 #else
2306             force_ident("\"", '$');
2307 #endif /* USE_5005THREADS */
2308             PL_nextval[PL_nexttoke].ival = 0;
2309             force_next('$');
2310             PL_nextval[PL_nexttoke].ival = 0;
2311             force_next('(');
2312             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2313             force_next(FUNC);
2314         }
2315         if (PL_lex_starts++) {
2316             s = PL_bufptr;
2317             Aop(OP_CONCAT);
2318         }
2319         return yylex();
2320
2321     case LEX_INTERPENDMAYBE:
2322         if (intuit_more(PL_bufptr)) {
2323             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2324             break;
2325         }
2326         /* FALL THROUGH */
2327
2328     case LEX_INTERPEND:
2329         if (PL_lex_dojoin) {
2330             PL_lex_dojoin = FALSE;
2331             PL_lex_state = LEX_INTERPCONCAT;
2332             return ')';
2333         }
2334         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2335             && SvEVALED(PL_lex_repl))
2336         {
2337             if (PL_bufptr != PL_bufend)
2338                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2339             PL_lex_repl = Nullsv;
2340         }
2341         /* FALLTHROUGH */
2342     case LEX_INTERPCONCAT:
2343 #ifdef DEBUGGING
2344         if (PL_lex_brackets)
2345             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2346 #endif
2347         if (PL_bufptr == PL_bufend)
2348             return sublex_done();
2349
2350         if (SvIVX(PL_linestr) == '\'') {
2351             SV *sv = newSVsv(PL_linestr);
2352             if (!PL_lex_inpat)
2353                 sv = tokeq(sv);
2354             else if ( PL_hints & HINT_NEW_RE )
2355                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2356             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2357             s = PL_bufend;
2358         }
2359         else {
2360             s = scan_const(PL_bufptr);
2361             if (*s == '\\')
2362                 PL_lex_state = LEX_INTERPCASEMOD;
2363             else
2364                 PL_lex_state = LEX_INTERPSTART;
2365         }
2366
2367         if (s != PL_bufptr) {
2368             PL_nextval[PL_nexttoke] = yylval;
2369             PL_expect = XTERM;
2370             force_next(THING);
2371             if (PL_lex_starts++)
2372                 Aop(OP_CONCAT);
2373             else {
2374                 PL_bufptr = s;
2375                 return yylex();
2376             }
2377         }
2378
2379         return yylex();
2380     case LEX_FORMLINE:
2381         PL_lex_state = LEX_NORMAL;
2382         s = scan_formline(PL_bufptr);
2383         if (!PL_lex_formbrack)
2384             goto rightbracket;
2385         OPERATOR(';');
2386     }
2387
2388     s = PL_bufptr;
2389     PL_oldoldbufptr = PL_oldbufptr;
2390     PL_oldbufptr = s;
2391     DEBUG_T( {
2392         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2393                       exp_name[PL_expect], s);
2394     } );
2395
2396   retry:
2397     switch (*s) {
2398     default:
2399         if (isIDFIRST_lazy_if(s,UTF))
2400             goto keylookup;
2401         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2402     case 4:
2403     case 26:
2404         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2405     case 0:
2406         if (!PL_rsfp) {
2407             PL_last_uni = 0;
2408             PL_last_lop = 0;
2409             if (PL_lex_brackets)
2410                 yyerror("Missing right curly or square bracket");
2411             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2412                         "### Tokener got EOF\n");
2413             } );
2414             TOKEN(0);
2415         }
2416         if (s++ < PL_bufend)
2417             goto retry;                 /* ignore stray nulls */
2418         PL_last_uni = 0;
2419         PL_last_lop = 0;
2420         if (!PL_in_eval && !PL_preambled) {
2421             PL_preambled = TRUE;
2422             sv_setpv(PL_linestr,incl_perldb());
2423             if (SvCUR(PL_linestr))
2424                 sv_catpv(PL_linestr,";");
2425             if (PL_preambleav){
2426                 while(AvFILLp(PL_preambleav) >= 0) {
2427                     SV *tmpsv = av_shift(PL_preambleav);
2428                     sv_catsv(PL_linestr, tmpsv);
2429                     sv_catpv(PL_linestr, ";");
2430                     sv_free(tmpsv);
2431                 }
2432                 sv_free((SV*)PL_preambleav);
2433                 PL_preambleav = NULL;
2434             }
2435             if (PL_minus_n || PL_minus_p) {
2436                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2437                 if (PL_minus_l)
2438                     sv_catpv(PL_linestr,"chomp;");
2439                 if (PL_minus_a) {
2440                     if (PL_minus_F) {
2441                         if (strchr("/'\"", *PL_splitstr)
2442                               && strchr(PL_splitstr + 1, *PL_splitstr))
2443                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2444                         else {
2445                             char delim;
2446                             s = "'~#\200\1'"; /* surely one char is unused...*/
2447                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2448                             delim = *s;
2449                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2450                                       "q" + (delim == '\''), delim);
2451                             for (s = PL_splitstr; *s; s++) {
2452                                 if (*s == '\\')
2453                                     sv_catpvn(PL_linestr, "\\", 1);
2454                                 sv_catpvn(PL_linestr, s, 1);
2455                             }
2456                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2457                         }
2458                     }
2459                     else
2460                         sv_catpv(PL_linestr,"our @F=split(' ');");
2461                 }
2462             }
2463             sv_catpv(PL_linestr, "\n");
2464             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2465             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2466             PL_last_lop = PL_last_uni = Nullch;
2467             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2468                 SV *sv = NEWSV(85,0);
2469
2470                 sv_upgrade(sv, SVt_PVMG);
2471                 sv_setsv(sv,PL_linestr);
2472                 (void)SvIOK_on(sv);
2473                 SvIVX(sv) = 0;
2474                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2475             }
2476             goto retry;
2477         }
2478         do {
2479             bof = PL_rsfp ? TRUE : FALSE;
2480             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2481               fake_eof:
2482                 if (PL_rsfp) {
2483                     if (PL_preprocess && !PL_in_eval)
2484                         (void)PerlProc_pclose(PL_rsfp);
2485                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2486                         PerlIO_clearerr(PL_rsfp);
2487                     else
2488                         (void)PerlIO_close(PL_rsfp);
2489                     PL_rsfp = Nullfp;
2490                     PL_doextract = FALSE;
2491                 }
2492                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2493                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2494                     sv_catpv(PL_linestr,";}");
2495                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2496                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2497                     PL_last_lop = PL_last_uni = Nullch;
2498                     PL_minus_n = PL_minus_p = 0;
2499                     goto retry;
2500                 }
2501                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2502                 PL_last_lop = PL_last_uni = Nullch;
2503                 sv_setpv(PL_linestr,"");
2504                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2505             }
2506             /* if it looks like the start of a BOM, check if it in fact is */
2507             else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2508 #ifdef PERLIO_IS_STDIO
2509 #  ifdef __GNU_LIBRARY__
2510 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2511 #      define FTELL_FOR_PIPE_IS_BROKEN
2512 #    endif
2513 #  else
2514 #    ifdef __GLIBC__
2515 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2516 #        define FTELL_FOR_PIPE_IS_BROKEN
2517 #      endif
2518 #    endif
2519 #  endif
2520 #endif
2521 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2522                 /* This loses the possibility to detect the bof
2523                  * situation on perl -P when the libc5 is being used.
2524                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2525                  */
2526                 if (!PL_preprocess)
2527                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2528 #else
2529                 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2530 #endif
2531                 if (bof) {
2532                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2533                     s = swallow_bom((U8*)s);
2534                 }
2535             }
2536             if (PL_doextract) {
2537                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2538                     PL_doextract = FALSE;
2539
2540                 /* Incest with pod. */
2541                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2542                     sv_setpv(PL_linestr, "");
2543                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2544                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2545                     PL_last_lop = PL_last_uni = Nullch;
2546                     PL_doextract = FALSE;
2547                 }
2548             }
2549             incline(s);
2550         } while (PL_doextract);
2551         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2552         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2553             SV *sv = NEWSV(85,0);
2554
2555             sv_upgrade(sv, SVt_PVMG);
2556             sv_setsv(sv,PL_linestr);
2557             (void)SvIOK_on(sv);
2558             SvIVX(sv) = 0;
2559             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2560         }
2561         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2562         PL_last_lop = PL_last_uni = Nullch;
2563         if (CopLINE(PL_curcop) == 1) {
2564             while (s < PL_bufend && isSPACE(*s))
2565                 s++;
2566             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2567                 s++;
2568             d = Nullch;
2569             if (!PL_in_eval) {
2570                 if (*s == '#' && *(s+1) == '!')
2571                     d = s + 2;
2572 #ifdef ALTERNATE_SHEBANG
2573                 else {
2574                     static char as[] = ALTERNATE_SHEBANG;
2575                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2576                         d = s + (sizeof(as) - 1);
2577                 }
2578 #endif /* ALTERNATE_SHEBANG */
2579             }
2580             if (d) {
2581                 char *ipath;
2582                 char *ipathend;
2583
2584                 while (isSPACE(*d))
2585                     d++;
2586                 ipath = d;
2587                 while (*d && !isSPACE(*d))
2588                     d++;
2589                 ipathend = d;
2590
2591 #ifdef ARG_ZERO_IS_SCRIPT
2592                 if (ipathend > ipath) {
2593                     /*
2594                      * HP-UX (at least) sets argv[0] to the script name,
2595                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2596                      * at least, set argv[0] to the basename of the Perl
2597                      * interpreter. So, having found "#!", we'll set it right.
2598                      */
2599                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2600                     assert(SvPOK(x) || SvGMAGICAL(x));
2601                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2602                         sv_setpvn(x, ipath, ipathend - ipath);
2603                         SvSETMAGIC(x);
2604                     }
2605                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2606                 }
2607 #endif /* ARG_ZERO_IS_SCRIPT */
2608
2609                 /*
2610                  * Look for options.
2611                  */
2612                 d = instr(s,"perl -");
2613                 if (!d) {
2614                     d = instr(s,"perl");
2615 #if defined(DOSISH)
2616                     /* avoid getting into infinite loops when shebang
2617                      * line contains "Perl" rather than "perl" */
2618                     if (!d) {
2619                         for (d = ipathend-4; d >= ipath; --d) {
2620                             if ((*d == 'p' || *d == 'P')
2621                                 && !ibcmp(d, "perl", 4))
2622                             {
2623                                 break;
2624                             }
2625                         }
2626                         if (d < ipath)
2627                             d = Nullch;
2628                     }
2629 #endif
2630                 }
2631 #ifdef ALTERNATE_SHEBANG
2632                 /*
2633                  * If the ALTERNATE_SHEBANG on this system starts with a
2634                  * character that can be part of a Perl expression, then if
2635                  * we see it but not "perl", we're probably looking at the
2636                  * start of Perl code, not a request to hand off to some
2637                  * other interpreter.  Similarly, if "perl" is there, but
2638                  * not in the first 'word' of the line, we assume the line
2639                  * contains the start of the Perl program.
2640                  */
2641                 if (d && *s != '#') {
2642                     char *c = ipath;
2643                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2644                         c++;
2645                     if (c < d)
2646                         d = Nullch;     /* "perl" not in first word; ignore */
2647                     else
2648                         *s = '#';       /* Don't try to parse shebang line */
2649                 }
2650 #endif /* ALTERNATE_SHEBANG */
2651 #ifndef MACOS_TRADITIONAL
2652                 if (!d &&
2653                     *s == '#' &&
2654                     ipathend > ipath &&
2655                     !PL_minus_c &&
2656                     !instr(s,"indir") &&
2657                     instr(PL_origargv[0],"perl"))
2658                 {
2659                     char **newargv;
2660
2661                     *ipathend = '\0';
2662                     s = ipathend + 1;
2663                     while (s < PL_bufend && isSPACE(*s))
2664                         s++;
2665                     if (s < PL_bufend) {
2666                         Newz(899,newargv,PL_origargc+3,char*);
2667                         newargv[1] = s;
2668                         while (s < PL_bufend && !isSPACE(*s))
2669                             s++;
2670                         *s = '\0';
2671                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2672                     }
2673                     else
2674                         newargv = PL_origargv;
2675                     newargv[0] = ipath;
2676                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2677                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2678                 }
2679 #endif
2680                 if (d) {
2681                     U32 oldpdb = PL_perldb;
2682                     bool oldn = PL_minus_n;
2683                     bool oldp = PL_minus_p;
2684
2685                     while (*d && !isSPACE(*d)) d++;
2686                     while (SPACE_OR_TAB(*d)) d++;
2687
2688                     if (*d++ == '-') {
2689                         bool switches_done = PL_doswitches;
2690                         do {
2691                             if (*d == 'M' || *d == 'm') {
2692                                 char *m = d;
2693                                 while (*d && !isSPACE(*d)) d++;
2694                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2695                                       (int)(d - m), m);
2696                             }
2697                             d = moreswitches(d);
2698                         } while (d);
2699                         if ((PERLDB_LINE && !oldpdb) ||
2700                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2701                               /* if we have already added "LINE: while (<>) {",
2702                                  we must not do it again */
2703                         {
2704                             sv_setpv(PL_linestr, "");
2705                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2706                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2707                             PL_last_lop = PL_last_uni = Nullch;
2708                             PL_preambled = FALSE;
2709                             if (PERLDB_LINE)
2710                                 (void)gv_fetchfile(PL_origfilename);
2711                             goto retry;
2712                         }
2713                         if (PL_doswitches && !switches_done) {
2714                             int argc = PL_origargc;
2715                             char **argv = PL_origargv;
2716                             do {
2717                                 argc--,argv++;
2718                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2719                             init_argv_symbols(argc,argv);
2720                         }
2721                     }
2722                 }
2723             }
2724         }
2725         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2726             PL_bufptr = s;
2727             PL_lex_state = LEX_FORMLINE;
2728             return yylex();
2729         }
2730         goto retry;
2731     case '\r':
2732 #ifdef PERL_STRICT_CR
2733         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2734         Perl_croak(aTHX_
2735       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2736 #endif
2737     case ' ': case '\t': case '\f': case 013:
2738 #ifdef MACOS_TRADITIONAL
2739     case '\312':
2740 #endif
2741         s++;
2742         goto retry;
2743     case '#':
2744     case '\n':
2745         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2746             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2747                 /* handle eval qq[#line 1 "foo"\n ...] */
2748                 CopLINE_dec(PL_curcop);
2749                 incline(s);
2750             }
2751             d = PL_bufend;
2752             while (s < d && *s != '\n')
2753                 s++;
2754             if (s < d)
2755                 s++;
2756             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2757               Perl_croak(aTHX_ "panic: input overflow");
2758             incline(s);
2759             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2760                 PL_bufptr = s;
2761                 PL_lex_state = LEX_FORMLINE;
2762                 return yylex();
2763             }
2764         }
2765         else {
2766             *s = '\0';
2767             PL_bufend = s;
2768         }
2769         goto retry;
2770     case '-':
2771         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2772             I32 ftst = 0;
2773
2774             s++;
2775             PL_bufptr = s;
2776             tmp = *s++;
2777
2778             while (s < PL_bufend && SPACE_OR_TAB(*s))
2779                 s++;
2780
2781             if (strnEQ(s,"=>",2)) {
2782                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2783                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2784                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2785                 } );
2786                 OPERATOR('-');          /* unary minus */
2787             }
2788             PL_last_uni = PL_oldbufptr;
2789             switch (tmp) {
2790             case 'r': ftst = OP_FTEREAD;        break;
2791             case 'w': ftst = OP_FTEWRITE;       break;
2792             case 'x': ftst = OP_FTEEXEC;        break;
2793             case 'o': ftst = OP_FTEOWNED;       break;
2794             case 'R': ftst = OP_FTRREAD;        break;
2795             case 'W': ftst = OP_FTRWRITE;       break;
2796             case 'X': ftst = OP_FTREXEC;        break;
2797             case 'O': ftst = OP_FTROWNED;       break;
2798             case 'e': ftst = OP_FTIS;           break;
2799             case 'z': ftst = OP_FTZERO;         break;
2800             case 's': ftst = OP_FTSIZE;         break;
2801             case 'f': ftst = OP_FTFILE;         break;
2802             case 'd': ftst = OP_FTDIR;          break;
2803             case 'l': ftst = OP_FTLINK;         break;
2804             case 'p': ftst = OP_FTPIPE;         break;
2805             case 'S': ftst = OP_FTSOCK;         break;
2806             case 'u': ftst = OP_FTSUID;         break;
2807             case 'g': ftst = OP_FTSGID;         break;
2808             case 'k': ftst = OP_FTSVTX;         break;
2809             case 'b': ftst = OP_FTBLK;          break;
2810             case 'c': ftst = OP_FTCHR;          break;
2811             case 't': ftst = OP_FTTTY;          break;
2812             case 'T': ftst = OP_FTTEXT;         break;
2813             case 'B': ftst = OP_FTBINARY;       break;
2814             case 'M': case 'A': case 'C':
2815                 gv_fetchpv("\024",TRUE, SVt_PV);
2816                 switch (tmp) {
2817                 case 'M': ftst = OP_FTMTIME;    break;
2818                 case 'A': ftst = OP_FTATIME;    break;
2819                 case 'C': ftst = OP_FTCTIME;    break;
2820                 default:                        break;
2821                 }
2822                 break;
2823             default:
2824                 break;
2825             }
2826             if (ftst) {
2827                 PL_last_lop_op = ftst;
2828                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2829                         "### Saw file test %c\n", (int)ftst);
2830                 } );
2831                 FTST(ftst);
2832             }
2833             else {
2834                 /* Assume it was a minus followed by a one-letter named
2835                  * subroutine call (or a -bareword), then. */
2836                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2837                         "### %c looked like a file test but was not\n",
2838                         (int)ftst);
2839                 } );
2840                 s -= 2;
2841             }
2842         }
2843         tmp = *s++;
2844         if (*s == tmp) {
2845             s++;
2846             if (PL_expect == XOPERATOR)
2847                 TERM(POSTDEC);
2848             else
2849                 OPERATOR(PREDEC);
2850         }
2851         else if (*s == '>') {
2852             s++;
2853             s = skipspace(s);
2854             if (isIDFIRST_lazy_if(s,UTF)) {
2855                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2856                 TOKEN(ARROW);
2857             }
2858             else if (*s == '$')
2859                 OPERATOR(ARROW);
2860             else
2861                 TERM(ARROW);
2862         }
2863         if (PL_expect == XOPERATOR)
2864             Aop(OP_SUBTRACT);
2865         else {
2866             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2867                 check_uni();
2868             OPERATOR('-');              /* unary minus */
2869         }
2870
2871     case '+':
2872         tmp = *s++;
2873         if (*s == tmp) {
2874             s++;
2875             if (PL_expect == XOPERATOR)
2876                 TERM(POSTINC);
2877             else
2878                 OPERATOR(PREINC);
2879         }
2880         if (PL_expect == XOPERATOR)
2881             Aop(OP_ADD);
2882         else {
2883             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2884                 check_uni();
2885             OPERATOR('+');
2886         }
2887
2888     case '*':
2889         if (PL_expect != XOPERATOR) {
2890             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2891             PL_expect = XOPERATOR;
2892             force_ident(PL_tokenbuf, '*');
2893             if (!*PL_tokenbuf)
2894                 PREREF('*');
2895             TERM('*');
2896         }
2897         s++;
2898         if (*s == '*') {
2899             s++;
2900             PWop(OP_POW);
2901         }
2902         Mop(OP_MULTIPLY);
2903
2904     case '%':
2905         if (PL_expect == XOPERATOR) {
2906             ++s;
2907             Mop(OP_MODULO);
2908         }
2909         PL_tokenbuf[0] = '%';
2910         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2911         if (!PL_tokenbuf[1]) {
2912             if (s == PL_bufend)
2913                 yyerror("Final % should be \\% or %name");
2914             PREREF('%');
2915         }
2916         PL_pending_ident = '%';
2917         TERM('%');
2918
2919     case '^':
2920         s++;
2921         BOop(OP_BIT_XOR);
2922     case '[':
2923         PL_lex_brackets++;
2924         /* FALL THROUGH */
2925     case '~':
2926     case ',':
2927         tmp = *s++;
2928         OPERATOR(tmp);
2929     case ':':
2930         if (s[1] == ':') {
2931             len = 0;
2932             goto just_a_word;
2933         }
2934         s++;
2935         switch (PL_expect) {
2936             OP *attrs;
2937         case XOPERATOR:
2938             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2939                 break;
2940             PL_bufptr = s;      /* update in case we back off */
2941             goto grabattrs;
2942         case XATTRBLOCK:
2943             PL_expect = XBLOCK;
2944             goto grabattrs;
2945         case XATTRTERM:
2946             PL_expect = XTERMBLOCK;
2947          grabattrs:
2948             s = skipspace(s);
2949             attrs = Nullop;
2950             while (isIDFIRST_lazy_if(s,UTF)) {
2951                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2952                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2953                     if (tmp < 0) tmp = -tmp;
2954                     switch (tmp) {
2955                     case KEY_or:
2956                     case KEY_and:
2957                     case KEY_for:
2958                     case KEY_unless:
2959                     case KEY_if:
2960                     case KEY_while:
2961                     case KEY_until:
2962                         goto got_attrs;
2963                     default:
2964                         break;
2965                     }
2966                 }
2967                 if (*d == '(') {
2968                     d = scan_str(d,TRUE,TRUE);
2969                     if (!d) {
2970                         /* MUST advance bufptr here to avoid bogus
2971                            "at end of line" context messages from yyerror().
2972                          */
2973                         PL_bufptr = s + len;
2974                         yyerror("Unterminated attribute parameter in attribute list");
2975                         if (attrs)
2976                             op_free(attrs);
2977                         return 0;       /* EOF indicator */
2978                     }
2979                 }
2980                 if (PL_lex_stuff) {
2981                     SV *sv = newSVpvn(s, len);
2982                     sv_catsv(sv, PL_lex_stuff);
2983                     attrs = append_elem(OP_LIST, attrs,
2984                                         newSVOP(OP_CONST, 0, sv));
2985                     SvREFCNT_dec(PL_lex_stuff);
2986                     PL_lex_stuff = Nullsv;
2987                 }
2988                 else {
2989                     if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
2990                         CvLVALUE_on(PL_compcv);
2991                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
2992                         CvLOCKED_on(PL_compcv);
2993                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
2994                         CvMETHOD_on(PL_compcv);
2995 #ifdef USE_ITHREADS
2996       else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
2997                         GvUNIQUE_on(cGVOPx_gv(yylval.opval));
2998 #endif
2999                     /* After we've set the flags, it could be argued that
3000                        we don't need to do the attributes.pm-based setting
3001                        process, and shouldn't bother appending recognized
3002                        flags. To experiment with that, uncomment the
3003                        following "else": */
3004                     else
3005                         attrs = append_elem(OP_LIST, attrs,
3006                                             newSVOP(OP_CONST, 0,
3007                                                     newSVpvn(s, len)));
3008                 }
3009                 s = skipspace(d);
3010                 if (*s == ':' && s[1] != ':')
3011                     s = skipspace(s+1);
3012                 else if (s == d)
3013                     break;      /* require real whitespace or :'s */
3014             }
3015             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3016             if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
3017                 char q = ((*s == '\'') ? '"' : '\'');
3018                 /* If here for an expression, and parsed no attrs, back off. */
3019                 if (tmp == '=' && !attrs) {
3020                     s = PL_bufptr;
3021                     break;
3022                 }
3023                 /* MUST advance bufptr here to avoid bogus "at end of line"
3024                    context messages from yyerror().
3025                  */
3026                 PL_bufptr = s;
3027                 if (!*s)
3028                     yyerror("Unterminated attribute list");
3029                 else
3030                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3031                                       q, *s, q));
3032                 if (attrs)
3033                     op_free(attrs);
3034                 OPERATOR(':');
3035             }
3036         got_attrs:
3037             if (attrs) {
3038                 PL_nextval[PL_nexttoke].opval = attrs;
3039                 force_next(THING);
3040             }
3041             TOKEN(COLONATTR);
3042         }
3043         OPERATOR(':');
3044     case '(':
3045         s++;
3046         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3047             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3048         else
3049             PL_expect = XTERM;
3050         TOKEN('(');
3051     case ';':
3052         CLINE;
3053         tmp = *s++;
3054         OPERATOR(tmp);
3055     case ')':
3056         tmp = *s++;
3057         s = skipspace(s);
3058         if (*s == '{')
3059             PREBLOCK(tmp);
3060         TERM(tmp);
3061     case ']':
3062         s++;
3063         if (PL_lex_brackets <= 0)
3064             yyerror("Unmatched right square bracket");
3065         else
3066             --PL_lex_brackets;
3067         if (PL_lex_state == LEX_INTERPNORMAL) {
3068             if (PL_lex_brackets == 0) {
3069                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3070                     PL_lex_state = LEX_INTERPEND;
3071             }
3072         }
3073         TERM(']');
3074     case '{':
3075       leftbracket:
3076         s++;
3077         if (PL_lex_brackets > 100) {
3078             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3079             if (newlb != PL_lex_brackstack) {
3080                 SAVEFREEPV(newlb);
3081                 PL_lex_brackstack = newlb;
3082             }
3083         }
3084         switch (PL_expect) {
3085         case XTERM:
3086             if (PL_lex_formbrack) {
3087                 s--;
3088                 PRETERMBLOCK(DO);
3089             }
3090             if (PL_oldoldbufptr == PL_last_lop)
3091                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3092             else
3093                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3094             OPERATOR(HASHBRACK);
3095         case XOPERATOR:
3096             while (s < PL_bufend && SPACE_OR_TAB(*s))
3097                 s++;
3098             d = s;
3099             PL_tokenbuf[0] = '\0';
3100             if (d < PL_bufend && *d == '-') {
3101                 PL_tokenbuf[0] = '-';
3102                 d++;
3103                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3104                     d++;
3105             }
3106             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3107                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3108                               FALSE, &len);
3109                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3110                     d++;
3111                 if (*d == '}') {
3112                     char minus = (PL_tokenbuf[0] == '-');
3113                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3114                     if (minus)
3115                         force_next('-');
3116                 }
3117             }
3118             /* FALL THROUGH */
3119         case XATTRBLOCK:
3120         case XBLOCK:
3121             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3122             PL_expect = XSTATE;
3123             break;
3124         case XATTRTERM:
3125         case XTERMBLOCK:
3126             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3127             PL_expect = XSTATE;
3128             break;
3129         default: {
3130                 char *t;
3131                 if (PL_oldoldbufptr == PL_last_lop)
3132                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3133                 else
3134                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3135                 s = skipspace(s);
3136                 if (*s == '}') {
3137                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3138                         PL_expect = XTERM;
3139                         /* This hack is to get the ${} in the message. */
3140                         PL_bufptr = s+1;
3141                         yyerror("syntax error");
3142                         break;
3143                     }
3144                     OPERATOR(HASHBRACK);
3145                 }
3146                 /* This hack serves to disambiguate a pair of curlies
3147                  * as being a block or an anon hash.  Normally, expectation
3148                  * determines that, but in cases where we're not in a
3149                  * position to expect anything in particular (like inside
3150                  * eval"") we have to resolve the ambiguity.  This code
3151                  * covers the case where the first term in the curlies is a
3152                  * quoted string.  Most other cases need to be explicitly
3153                  * disambiguated by prepending a `+' before the opening
3154                  * curly in order to force resolution as an anon hash.
3155                  *
3156                  * XXX should probably propagate the outer expectation
3157                  * into eval"" to rely less on this hack, but that could
3158                  * potentially break current behavior of eval"".
3159                  * GSAR 97-07-21
3160                  */
3161                 t = s;
3162                 if (*s == '\'' || *s == '"' || *s == '`') {
3163                     /* common case: get past first string, handling escapes */
3164                     for (t++; t < PL_bufend && *t != *s;)
3165                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3166                             t++;
3167                     t++;
3168                 }
3169                 else if (*s == 'q') {
3170                     if (++t < PL_bufend
3171                         && (!isALNUM(*t)
3172                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3173                                 && !isALNUM(*t))))
3174                     {
3175                         char *tmps;
3176                         char open, close, term;
3177                         I32 brackets = 1;
3178
3179                         while (t < PL_bufend && isSPACE(*t))
3180                             t++;
3181                         term = *t;
3182                         open = term;
3183                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3184                             term = tmps[5];
3185                         close = term;
3186                         if (open == close)
3187                             for (t++; t < PL_bufend; t++) {
3188                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3189                                     t++;
3190                                 else if (*t == open)
3191                                     break;
3192                             }
3193                         else
3194                             for (t++; t < PL_bufend; t++) {
3195                                 if (*t == '\\' && t+1 < PL_bufend)
3196                                     t++;
3197                                 else if (*t == close && --brackets <= 0)
3198                                     break;
3199                                 else if (*t == open)
3200                                     brackets++;
3201                             }
3202                     }
3203                     t++;
3204                 }
3205                 else if (isALNUM_lazy_if(t,UTF)) {
3206                     t += UTF8SKIP(t);
3207                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3208                          t += UTF8SKIP(t);
3209                 }
3210                 while (t < PL_bufend && isSPACE(*t))
3211                     t++;
3212                 /* if comma follows first term, call it an anon hash */
3213                 /* XXX it could be a comma expression with loop modifiers */
3214                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3215                                    || (*t == '=' && t[1] == '>')))
3216                     OPERATOR(HASHBRACK);
3217                 if (PL_expect == XREF)
3218                     PL_expect = XTERM;
3219                 else {
3220                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3221                     PL_expect = XSTATE;
3222                 }
3223             }
3224             break;
3225         }
3226         yylval.ival = CopLINE(PL_curcop);
3227         if (isSPACE(*s) || *s == '#')
3228             PL_copline = NOLINE;   /* invalidate current command line number */
3229         TOKEN('{');
3230     case '}':
3231       rightbracket:
3232         s++;
3233         if (PL_lex_brackets <= 0)
3234             yyerror("Unmatched right curly bracket");
3235         else
3236             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3237         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3238             PL_lex_formbrack = 0;
3239         if (PL_lex_state == LEX_INTERPNORMAL) {
3240             if (PL_lex_brackets == 0) {
3241                 if (PL_expect & XFAKEBRACK) {
3242                     PL_expect &= XENUMMASK;
3243                     PL_lex_state = LEX_INTERPEND;
3244                     PL_bufptr = s;
3245                     return yylex();     /* ignore fake brackets */
3246                 }
3247                 if (*s == '-' && s[1] == '>')
3248                     PL_lex_state = LEX_INTERPENDMAYBE;
3249                 else if (*s != '[' && *s != '{')
3250                     PL_lex_state = LEX_INTERPEND;
3251             }
3252         }
3253         if (PL_expect & XFAKEBRACK) {
3254             PL_expect &= XENUMMASK;
3255             PL_bufptr = s;
3256             return yylex();             /* ignore fake brackets */
3257         }
3258         force_next('}');
3259         TOKEN(';');
3260     case '&':
3261         s++;
3262         tmp = *s++;
3263         if (tmp == '&')
3264             AOPERATOR(ANDAND);
3265         s--;
3266         if (PL_expect == XOPERATOR) {
3267             if (ckWARN(WARN_SEMICOLON)
3268                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3269             {
3270                 CopLINE_dec(PL_curcop);
3271                 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3272                 CopLINE_inc(PL_curcop);
3273             }
3274             BAop(OP_BIT_AND);
3275         }
3276
3277         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3278         if (*PL_tokenbuf) {
3279             PL_expect = XOPERATOR;
3280             force_ident(PL_tokenbuf, '&');
3281         }
3282         else
3283             PREREF('&');
3284         yylval.ival = (OPpENTERSUB_AMPER<<8);
3285         TERM('&');
3286
3287     case '|':
3288         s++;
3289         tmp = *s++;
3290         if (tmp == '|')
3291             AOPERATOR(OROR);
3292         s--;
3293         BOop(OP_BIT_OR);
3294     case '=':
3295         s++;
3296         tmp = *s++;
3297         if (tmp == '=')
3298             Eop(OP_EQ);
3299         if (tmp == '>')
3300             OPERATOR(',');
3301         if (tmp == '~')
3302             PMop(OP_MATCH);
3303         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3304             Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3305         s--;
3306         if (PL_expect == XSTATE && isALPHA(tmp) &&
3307                 (s == PL_linestart+1 || s[-2] == '\n') )
3308         {
3309             if (PL_in_eval && !PL_rsfp) {
3310                 d = PL_bufend;
3311                 while (s < d) {
3312                     if (*s++ == '\n') {
3313                         incline(s);
3314                         if (strnEQ(s,"=cut",4)) {
3315                             s = strchr(s,'\n');
3316                             if (s)
3317                                 s++;
3318                             else
3319                                 s = d;
3320                             incline(s);
3321                             goto retry;
3322                         }
3323                     }
3324                 }
3325                 goto retry;
3326             }
3327             s = PL_bufend;
3328             PL_doextract = TRUE;
3329             goto retry;
3330         }
3331         if (PL_lex_brackets < PL_lex_formbrack) {
3332             char *t;
3333 #ifdef PERL_STRICT_CR
3334             for (t = s; SPACE_OR_TAB(*t); t++) ;
3335 #else
3336             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3337 #endif
3338             if (*t == '\n' || *t == '#') {
3339                 s--;
3340                 PL_expect = XBLOCK;
3341                 goto leftbracket;
3342             }
3343         }
3344         yylval.ival = 0;
3345         OPERATOR(ASSIGNOP);
3346     case '!':
3347         s++;
3348         tmp = *s++;
3349         if (tmp == '=')
3350             Eop(OP_NE);
3351         if (tmp == '~')
3352             PMop(OP_NOT);
3353         s--;
3354         OPERATOR('!');
3355     case '<':
3356         if (PL_expect != XOPERATOR) {
3357             if (s[1] != '<' && !strchr(s,'>'))
3358                 check_uni();
3359             if (s[1] == '<')
3360                 s = scan_heredoc(s);
3361             else
3362                 s = scan_inputsymbol(s);
3363             TERM(sublex_start());
3364         }
3365         s++;
3366         tmp = *s++;
3367         if (tmp == '<')
3368             SHop(OP_LEFT_SHIFT);
3369         if (tmp == '=') {
3370             tmp = *s++;
3371             if (tmp == '>')
3372                 Eop(OP_NCMP);
3373             s--;
3374             Rop(OP_LE);
3375         }
3376         s--;
3377         Rop(OP_LT);
3378     case '>':
3379         s++;
3380         tmp = *s++;
3381         if (tmp == '>')
3382             SHop(OP_RIGHT_SHIFT);
3383         if (tmp == '=')
3384             Rop(OP_GE);
3385         s--;
3386         Rop(OP_GT);
3387
3388     case '$':
3389         CLINE;
3390
3391         if (PL_expect == XOPERATOR) {
3392             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3393                 PL_expect = XTERM;
3394                 depcom();
3395                 return ','; /* grandfather non-comma-format format */
3396             }
3397         }
3398
3399         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3400             PL_tokenbuf[0] = '@';
3401             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3402                            sizeof PL_tokenbuf - 1, FALSE);
3403             if (PL_expect == XOPERATOR)
3404                 no_op("Array length", s);
3405             if (!PL_tokenbuf[1])
3406                 PREREF(DOLSHARP);
3407             PL_expect = XOPERATOR;
3408             PL_pending_ident = '#';
3409             TOKEN(DOLSHARP);
3410         }
3411
3412         PL_tokenbuf[0] = '$';
3413         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3414                        sizeof PL_tokenbuf - 1, FALSE);
3415         if (PL_expect == XOPERATOR)
3416             no_op("Scalar", s);
3417         if (!PL_tokenbuf[1]) {
3418             if (s == PL_bufend)
3419                 yyerror("Final $ should be \\$ or $name");
3420             PREREF('$');
3421         }
3422
3423         /* This kludge not intended to be bulletproof. */
3424         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3425             yylval.opval = newSVOP(OP_CONST, 0,
3426                                    newSViv(PL_compiling.cop_arybase));
3427             yylval.opval->op_private = OPpCONST_ARYBASE;
3428             TERM(THING);
3429         }
3430
3431         d = s;
3432         tmp = (I32)*s;
3433         if (PL_lex_state == LEX_NORMAL)
3434             s = skipspace(s);
3435
3436         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3437             char *t;
3438             if (*s == '[') {
3439                 PL_tokenbuf[0] = '@';
3440                 if (ckWARN(WARN_SYNTAX)) {
3441                     for(t = s + 1;
3442                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3443                         t++) ;
3444                     if (*t++ == ',') {
3445                         PL_bufptr = skipspace(PL_bufptr);
3446                         while (t < PL_bufend && *t != ']')
3447                             t++;
3448                         Perl_warner(aTHX_ WARN_SYNTAX,
3449                                 "Multidimensional syntax %.*s not supported",
3450                                 (t - PL_bufptr) + 1, PL_bufptr);
3451                     }
3452                 }
3453             }
3454             else if (*s == '{') {
3455                 PL_tokenbuf[0] = '%';
3456                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3457                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3458                 {
3459                     char tmpbuf[sizeof PL_tokenbuf];
3460                     STRLEN len;
3461                     for (t++; isSPACE(*t); t++) ;
3462                     if (isIDFIRST_lazy_if(t,UTF)) {
3463                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3464                         for (; isSPACE(*t); t++) ;
3465                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3466                             Perl_warner(aTHX_ WARN_SYNTAX,
3467                                 "You need to quote \"%s\"", tmpbuf);
3468                     }
3469                 }
3470             }
3471         }
3472
3473         PL_expect = XOPERATOR;
3474         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3475             bool islop = (PL_last_lop == PL_oldoldbufptr);
3476             if (!islop || PL_last_lop_op == OP_GREPSTART)
3477                 PL_expect = XOPERATOR;
3478             else if (strchr("$@\"'`q", *s))
3479                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3480             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3481                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3482             else if (isIDFIRST_lazy_if(s,UTF)) {
3483                 char tmpbuf[sizeof PL_tokenbuf];
3484                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3485                 if ((tmp = keyword(tmpbuf, len))) {
3486                     /* binary operators exclude handle interpretations */
3487                     switch (tmp) {
3488                     case -KEY_x:
3489                     case -KEY_eq:
3490                     case -KEY_ne:
3491                     case -KEY_gt:
3492                     case -KEY_lt:
3493                     case -KEY_ge:
3494                     case -KEY_le:
3495                     case -KEY_cmp:
3496                         break;
3497                     default:
3498                         PL_expect = XTERM;      /* e.g. print $fh length() */
3499                         break;
3500                     }
3501                 }
3502                 else {
3503                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3504                     if (gv && GvCVu(gv))
3505                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3506                 }
3507             }
3508             else if (isDIGIT(*s))
3509                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3510             else if (*s == '.' && isDIGIT(s[1]))
3511                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3512             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3513                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3514             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3515                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3516         }
3517         PL_pending_ident = '$';
3518         TOKEN('$');
3519
3520     case '@':
3521         if (PL_expect == XOPERATOR)
3522             no_op("Array", s);
3523         PL_tokenbuf[0] = '@';
3524         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3525         if (!PL_tokenbuf[1]) {
3526             if (s == PL_bufend)
3527                 yyerror("Final @ should be \\@ or @name");
3528             PREREF('@');
3529         }
3530         if (PL_lex_state == LEX_NORMAL)
3531             s = skipspace(s);
3532         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3533             if (*s == '{')
3534                 PL_tokenbuf[0] = '%';
3535
3536             /* Warn about @ where they meant $. */
3537             if (ckWARN(WARN_SYNTAX)) {
3538                 if (*s == '[' || *s == '{') {
3539                     char *t = s + 1;
3540                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3541                         t++;
3542                     if (*t == '}' || *t == ']') {
3543                         t++;
3544                         PL_bufptr = skipspace(PL_bufptr);
3545                         Perl_warner(aTHX_ WARN_SYNTAX,
3546                             "Scalar value %.*s better written as $%.*s",
3547                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3548                     }
3549                 }
3550             }
3551         }
3552         PL_pending_ident = '@';
3553         TERM('@');
3554
3555     case '/':                   /* may either be division or pattern */
3556     case '?':                   /* may either be conditional or pattern */
3557         if (PL_expect != XOPERATOR) {
3558             /* Disable warning on "study /blah/" */
3559             if (PL_oldoldbufptr == PL_last_uni
3560                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3561                     || memNE(PL_last_uni, "study", 5)
3562                     || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3563                 check_uni();
3564             s = scan_pat(s,OP_MATCH);
3565             TERM(sublex_start());
3566         }
3567         tmp = *s++;
3568         if (tmp == '/')
3569             Mop(OP_DIVIDE);
3570         OPERATOR(tmp);
3571
3572     case '.':
3573         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3574 #ifdef PERL_STRICT_CR
3575             && s[1] == '\n'
3576 #else
3577             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3578 #endif
3579             && (s == PL_linestart || s[-1] == '\n') )
3580         {
3581             PL_lex_formbrack = 0;
3582             PL_expect = XSTATE;
3583             goto rightbracket;
3584         }
3585         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3586             tmp = *s++;
3587             if (*s == tmp) {
3588                 s++;
3589                 if (*s == tmp) {
3590                     s++;
3591                     yylval.ival = OPf_SPECIAL;
3592                 }
3593                 else
3594                     yylval.ival = 0;
3595                 OPERATOR(DOTDOT);
3596             }
3597             if (PL_expect != XOPERATOR)
3598                 check_uni();
3599             Aop(OP_CONCAT);
3600         }
3601         /* FALL THROUGH */
3602     case '0': case '1': case '2': case '3': case '4':
3603     case '5': case '6': case '7': case '8': case '9':
3604         s = scan_num(s, &yylval);
3605         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3606                     "### Saw number in '%s'\n", s);
3607         } );
3608         if (PL_expect == XOPERATOR)
3609             no_op("Number",s);
3610         TERM(THING);
3611
3612     case '\'':
3613         s = scan_str(s,FALSE,FALSE);
3614         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3615                     "### Saw string before '%s'\n", s);
3616         } );
3617         if (PL_expect == XOPERATOR) {
3618             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3619                 PL_expect = XTERM;
3620                 depcom();
3621                 return ',';     /* grandfather non-comma-format format */
3622             }
3623             else
3624                 no_op("String",s);
3625         }
3626         if (!s)
3627             missingterm((char*)0);
3628         yylval.ival = OP_CONST;
3629         TERM(sublex_start());
3630
3631     case '"':
3632         s = scan_str(s,FALSE,FALSE);
3633         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3634                     "### Saw string before '%s'\n", s);
3635         } );
3636         if (PL_expect == XOPERATOR) {
3637             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3638                 PL_expect = XTERM;
3639                 depcom();
3640                 return ',';     /* grandfather non-comma-format format */
3641             }
3642             else
3643                 no_op("String",s);
3644         }
3645         if (!s)
3646             missingterm((char*)0);
3647         yylval.ival = OP_CONST;
3648         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3649             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3650                 yylval.ival = OP_STRINGIFY;
3651                 break;
3652             }
3653         }
3654         TERM(sublex_start());
3655
3656     case '`':
3657         s = scan_str(s,FALSE,FALSE);
3658         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3659                     "### Saw backtick string before '%s'\n", s);
3660         } );
3661         if (PL_expect == XOPERATOR)
3662             no_op("Backticks",s);
3663         if (!s)
3664             missingterm((char*)0);
3665         yylval.ival = OP_BACKTICK;
3666         set_csh();
3667         TERM(sublex_start());
3668
3669     case '\\':
3670         s++;
3671         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3672             Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3673                         *s, *s);
3674         if (PL_expect == XOPERATOR)
3675             no_op("Backslash",s);
3676         OPERATOR(REFGEN);
3677
3678     case 'v':
3679         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3680             char *start = s;
3681             start++;
3682             start++;
3683             while (isDIGIT(*start) || *start == '_')
3684                 start++;
3685             if (*start == '.' && isDIGIT(start[1])) {
3686                 s = scan_num(s, &yylval);
3687                 TERM(THING);
3688             }
3689             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3690             else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3691                 char c = *start;
3692                 GV *gv;
3693                 *start = '\0';
3694                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3695                 *start = c;
3696                 if (!gv) {
3697                     s = scan_num(s, &yylval);
3698                     TERM(THING);
3699                 }
3700             }
3701         }
3702         goto keylookup;
3703     case 'x':
3704         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3705             s++;
3706             Mop(OP_REPEAT);
3707         }
3708         goto keylookup;
3709
3710     case '_':
3711     case 'a': case 'A':
3712     case 'b': case 'B':
3713     case 'c': case 'C':
3714     case 'd': case 'D':
3715     case 'e': case 'E':
3716     case 'f': case 'F':
3717     case 'g': case 'G':
3718     case 'h': case 'H':
3719     case 'i': case 'I':
3720     case 'j': case 'J':
3721     case 'k': case 'K':
3722     case 'l': case 'L':
3723     case 'm': case 'M':
3724     case 'n': case 'N':
3725     case 'o': case 'O':
3726     case 'p': case 'P':
3727     case 'q': case 'Q':
3728     case 'r': case 'R':
3729     case 's': case 'S':
3730     case 't': case 'T':
3731     case 'u': case 'U':
3732               case 'V':
3733     case 'w': case 'W':
3734               case 'X':
3735     case 'y': case 'Y':
3736     case 'z': case 'Z':
3737
3738       keylookup: {
3739         gv = Nullgv;
3740         gvp = 0;
3741
3742         PL_bufptr = s;
3743         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3744
3745         /* Some keywords can be followed by any delimiter, including ':' */
3746         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3747                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3748                              (PL_tokenbuf[0] == 'q' &&
3749                               strchr("qwxr", PL_tokenbuf[1])))));
3750
3751         /* x::* is just a word, unless x is "CORE" */
3752         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3753             goto just_a_word;
3754
3755         d = s;
3756         while (d < PL_bufend && isSPACE(*d))
3757                 d++;    /* no comments skipped here, or s### is misparsed */
3758
3759         /* Is this a label? */
3760         if (!tmp && PL_expect == XSTATE
3761               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3762             s = d + 1;
3763             yylval.pval = savepv(PL_tokenbuf);
3764             CLINE;
3765             TOKEN(LABEL);
3766         }
3767
3768         /* Check for keywords */
3769         tmp = keyword(PL_tokenbuf, len);
3770
3771         /* Is this a word before a => operator? */
3772         if (*d == '=' && d[1] == '>') {
3773             CLINE;
3774             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3775             yylval.opval->op_private = OPpCONST_BARE;
3776             if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3777               SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3778             TERM(WORD);
3779         }
3780
3781         if (tmp < 0) {                  /* second-class keyword? */
3782             GV *ogv = Nullgv;   /* override (winner) */
3783             GV *hgv = Nullgv;   /* hidden (loser) */
3784             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3785                 CV *cv;
3786                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3787                     (cv = GvCVu(gv)))
3788                 {
3789                     if (GvIMPORTED_CV(gv))
3790                         ogv = gv;
3791                     else if (! CvMETHOD(cv))
3792                         hgv = gv;
3793                 }
3794                 if (!ogv &&
3795                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3796                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3797                     GvCVu(gv) && GvIMPORTED_CV(gv))
3798                 {
3799                     ogv = gv;
3800                 }
3801             }
3802             if (ogv) {
3803                 tmp = 0;                /* overridden by import or by GLOBAL */
3804             }
3805             else if (gv && !gvp
3806                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3807                      && GvCVu(gv)
3808                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3809             {
3810                 tmp = 0;                /* any sub overrides "weak" keyword */
3811             }
3812             else {                      /* no override */
3813                 tmp = -tmp;
3814                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3815                     Perl_warner(aTHX_ WARN_MISC,
3816                             "dump() better written as CORE::dump()");
3817                 }
3818                 gv = Nullgv;
3819                 gvp = 0;
3820                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3821                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3822                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3823                         "Ambiguous call resolved as CORE::%s(), %s",
3824                          GvENAME(hgv), "qualify as such or use &");
3825             }
3826         }
3827
3828       reserved_word:
3829         switch (tmp) {
3830
3831         default:                        /* not a keyword */
3832           just_a_word: {
3833                 SV *sv;
3834                 int pkgname = 0;
3835                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3836
3837                 /* Get the rest if it looks like a package qualifier */
3838
3839                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3840                     STRLEN morelen;
3841                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3842                                   TRUE, &morelen);
3843                     if (!morelen)
3844                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3845                                 *s == '\'' ? "'" : "::");
3846                     len += morelen;
3847                     pkgname = 1;
3848                 }
3849
3850                 if (PL_expect == XOPERATOR) {
3851                     if (PL_bufptr == PL_linestart) {
3852                         CopLINE_dec(PL_curcop);
3853                         Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3854                         CopLINE_inc(PL_curcop);
3855                     }
3856                     else
3857                         no_op("Bareword",s);
3858                 }
3859
3860                 /* Look for a subroutine with this name in current package,
3861                    unless name is "Foo::", in which case Foo is a bearword
3862                    (and a package name). */
3863
3864                 if (len > 2 &&
3865                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3866                 {
3867                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3868                         Perl_warner(aTHX_ WARN_BAREWORD,
3869                             "Bareword \"%s\" refers to nonexistent package",
3870                              PL_tokenbuf);
3871                     len -= 2;
3872                     PL_tokenbuf[len] = '\0';
3873                     gv = Nullgv;
3874                     gvp = 0;
3875                 }
3876                 else {
3877                     len = 0;
3878                     if (!gv)
3879                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3880                 }
3881
3882                 /* if we saw a global override before, get the right name */
3883
3884                 if (gvp) {
3885                     sv = newSVpvn("CORE::GLOBAL::",14);
3886                     sv_catpv(sv,PL_tokenbuf);
3887                 }
3888                 else
3889                     sv = newSVpv(PL_tokenbuf,0);
3890
3891                 /* Presume this is going to be a bareword of some sort. */
3892
3893                 CLINE;
3894                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3895                 yylval.opval->op_private = OPpCONST_BARE;
3896
3897                 /* And if "Foo::", then that's what it certainly is. */
3898
3899                 if (len)
3900                     goto safe_bareword;
3901
3902                 /* See if it's the indirect object for a list operator. */
3903
3904                 if (PL_oldoldbufptr &&
3905                     PL_oldoldbufptr < PL_bufptr &&
3906                     (PL_oldoldbufptr == PL_last_lop
3907                      || PL_oldoldbufptr == PL_last_uni) &&
3908                     /* NO SKIPSPACE BEFORE HERE! */
3909                     (PL_expect == XREF ||
3910                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3911                 {
3912                     bool immediate_paren = *s == '(';
3913
3914                     /* (Now we can afford to cross potential line boundary.) */
3915                     s = skipspace(s);
3916
3917                     /* Two barewords in a row may indicate method call. */
3918
3919                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3920                         return tmp;
3921
3922                     /* If not a declared subroutine, it's an indirect object. */
3923                     /* (But it's an indir obj regardless for sort.) */
3924
3925                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3926                          ((!gv || !GvCVu(gv)) &&
3927                         (PL_last_lop_op != OP_MAPSTART &&
3928                          PL_last_lop_op != OP_GREPSTART))))
3929                     {
3930                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3931                         goto bareword;
3932                     }
3933                 }
3934
3935                 PL_expect = XOPERATOR;
3936                 s = skipspace(s);
3937
3938                 /* Is this a word before a => operator? */
3939                 if (*s == '=' && s[1] == '>' && !pkgname) {
3940                     CLINE;
3941                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3942                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3943                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3944                     TERM(WORD);
3945                 }
3946
3947                 /* If followed by a paren, it's certainly a subroutine. */
3948                 if (*s == '(') {
3949                     CLINE;
3950                     if (gv && GvCVu(gv)) {
3951                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3952                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3953                             s = d + 1;
3954                             goto its_constant;
3955                         }
3956                     }
3957                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3958                     PL_expect = XOPERATOR;
3959                     force_next(WORD);
3960                     yylval.ival = 0;
3961                     TOKEN('&');
3962                 }
3963
3964                 /* If followed by var or block, call it a method (unless sub) */
3965
3966                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3967                     PL_last_lop = PL_oldbufptr;
3968                     PL_last_lop_op = OP_METHOD;
3969                     PREBLOCK(METHOD);
3970                 }
3971
3972                 /* If followed by a bareword, see if it looks like indir obj. */
3973
3974                 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3975                     return tmp;
3976
3977                 /* Not a method, so call it a subroutine (if defined) */
3978
3979                 if (gv && GvCVu(gv)) {
3980                     CV* cv;
3981                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3982                         Perl_warner(aTHX_ WARN_AMBIGUOUS,
3983                                 "Ambiguous use of -%s resolved as -&%s()",
3984                                 PL_tokenbuf, PL_tokenbuf);
3985                     /* Check for a constant sub */
3986                     cv = GvCV(gv);
3987                     if ((sv = cv_const_sv(cv))) {
3988                   its_constant:
3989                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3990                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3991                         yylval.opval->op_private = 0;
3992                         TOKEN(WORD);
3993                     }
3994
3995                     /* Resolve to GV now. */
3996                     op_free(yylval.opval);
3997                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3998                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3999                     PL_last_lop = PL_oldbufptr;
4000                     PL_last_lop_op = OP_ENTERSUB;
4001                     /* Is there a prototype? */
4002                     if (SvPOK(cv)) {
4003                         STRLEN len;
4004                         char *proto = SvPV((SV*)cv, len);
4005                         if (!len)
4006                             TERM(FUNC0SUB);
4007                         if (strEQ(proto, "$"))
4008                             OPERATOR(UNIOPSUB);
4009                         if (*proto == '&' && *s == '{') {
4010                             sv_setpv(PL_subname,"__ANON__");
4011                             PREBLOCK(LSTOPSUB);
4012                         }
4013                     }
4014                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4015                     PL_expect = XTERM;
4016                     force_next(WORD);
4017                     TOKEN(NOAMP);
4018                 }
4019
4020                 /* Call it a bare word */
4021
4022                 if (PL_hints & HINT_STRICT_SUBS)
4023                     yylval.opval->op_private |= OPpCONST_STRICT;
4024                 else {
4025                 bareword:
4026                     if (ckWARN(WARN_RESERVED)) {
4027                         if (lastchar != '-') {
4028                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4029                             if (!*d && strNE(PL_tokenbuf,"main"))
4030                                 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
4031                                        PL_tokenbuf);
4032                         }
4033                     }
4034                 }
4035
4036             safe_bareword:
4037                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4038                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4039                         "Operator or semicolon missing before %c%s",
4040                         lastchar, PL_tokenbuf);
4041                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4042                         "Ambiguous use of %c resolved as operator %c",
4043                         lastchar, lastchar);
4044                 }
4045                 TOKEN(WORD);
4046             }
4047
4048         case KEY___FILE__:
4049             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4050                                         newSVpv(CopFILE(PL_curcop),0));
4051             TERM(THING);
4052
4053         case KEY___LINE__:
4054             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4055                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4056             TERM(THING);
4057
4058         case KEY___PACKAGE__:
4059             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4060                                         (PL_curstash
4061                                          ? newSVsv(PL_curstname)
4062                                          : &PL_sv_undef));
4063             TERM(THING);
4064
4065         case KEY___DATA__:
4066         case KEY___END__: {
4067             GV *gv;
4068
4069             /*SUPPRESS 560*/
4070             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4071                 char *pname = "main";
4072                 if (PL_tokenbuf[2] == 'D')
4073                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4074                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4075                 GvMULTI_on(gv);
4076                 if (!GvIO(gv))
4077                     GvIOp(gv) = newIO();
4078                 IoIFP(GvIOp(gv)) = PL_rsfp;
4079 #if defined(HAS_FCNTL) && defined(F_SETFD)
4080                 {
4081                     int fd = PerlIO_fileno(PL_rsfp);
4082                     fcntl(fd,F_SETFD,fd >= 3);
4083                 }
4084 #endif
4085                 /* Mark this internal pseudo-handle as clean */
4086                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4087                 if (PL_preprocess)
4088                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4089                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4090                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4091                 else
4092                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4093 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4094                 /* if the script was opened in binmode, we need to revert
4095                  * it to text mode for compatibility; but only iff it has CRs
4096                  * XXX this is a questionable hack at best. */
4097                 if (PL_bufend-PL_bufptr > 2
4098                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4099                 {
4100                     Off_t loc = 0;
4101                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4102                         loc = PerlIO_tell(PL_rsfp);
4103                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4104                     }
4105 #ifdef NETWARE
4106                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4107 #else
4108                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4109 #endif  /* NETWARE */
4110 #ifdef PERLIO_IS_STDIO /* really? */
4111 #  if defined(__BORLANDC__)
4112                         /* XXX see note in do_binmode() */
4113                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4114 #  endif
4115 #endif
4116                         if (loc > 0)
4117                             PerlIO_seek(PL_rsfp, loc, 0);
4118                     }
4119                 }
4120 #endif
4121 #ifdef PERLIO_LAYERS
4122                 if (UTF && !IN_BYTES)
4123                     PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4124 #endif
4125                 PL_rsfp = Nullfp;
4126             }
4127             goto fake_eof;
4128         }
4129
4130         case KEY_AUTOLOAD:
4131         case KEY_DESTROY:
4132         case KEY_BEGIN:
4133         case KEY_CHECK:
4134         case KEY_INIT:
4135         case KEY_END:
4136             if (PL_expect == XSTATE) {
4137                 s = PL_bufptr;
4138                 goto really_sub;
4139             }
4140             goto just_a_word;
4141
4142         case KEY_CORE:
4143             if (*s == ':' && s[1] == ':') {
4144                 s += 2;
4145                 d = s;
4146                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4147                 if (!(tmp = keyword(PL_tokenbuf, len)))
4148                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4149                 if (tmp < 0)
4150                     tmp = -tmp;
4151                 goto reserved_word;
4152             }
4153             goto just_a_word;
4154
4155         case KEY_abs:
4156             UNI(OP_ABS);
4157
4158         case KEY_alarm:
4159             UNI(OP_ALARM);
4160
4161         case KEY_accept:
4162             LOP(OP_ACCEPT,XTERM);
4163
4164         case KEY_and:
4165             OPERATOR(ANDOP);
4166
4167         case KEY_atan2:
4168             LOP(OP_ATAN2,XTERM);
4169
4170         case KEY_bind:
4171             LOP(OP_BIND,XTERM);
4172
4173         case KEY_binmode:
4174             LOP(OP_BINMODE,XTERM);
4175
4176         case KEY_bless:
4177             LOP(OP_BLESS,XTERM);
4178
4179         case KEY_chop:
4180             UNI(OP_CHOP);
4181
4182         case KEY_continue:
4183             PREBLOCK(CONTINUE);
4184
4185         case KEY_chdir:
4186             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4187             UNI(OP_CHDIR);
4188
4189         case KEY_close:
4190             UNI(OP_CLOSE);
4191
4192         case KEY_closedir:
4193             UNI(OP_CLOSEDIR);
4194
4195         case KEY_cmp:
4196             Eop(OP_SCMP);
4197
4198         case KEY_caller:
4199             UNI(OP_CALLER);
4200
4201         case KEY_crypt:
4202 #ifdef FCRYPT
4203             if (!PL_cryptseen) {
4204                 PL_cryptseen = TRUE;
4205                 init_des();
4206             }
4207 #endif
4208             LOP(OP_CRYPT,XTERM);
4209
4210         case KEY_chmod:
4211             LOP(OP_CHMOD,XTERM);
4212
4213         case KEY_chown:
4214             LOP(OP_CHOWN,XTERM);
4215
4216         case KEY_connect:
4217             LOP(OP_CONNECT,XTERM);
4218
4219         case KEY_chr:
4220             UNI(OP_CHR);
4221
4222         case KEY_cos:
4223             UNI(OP_COS);
4224
4225         case KEY_chroot:
4226             UNI(OP_CHROOT);
4227
4228         case KEY_do:
4229             s = skipspace(s);
4230             if (*s == '{')
4231                 PRETERMBLOCK(DO);
4232             if (*s != '\'')
4233                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4234             OPERATOR(DO);
4235
4236         case KEY_die:
4237             PL_hints |= HINT_BLOCK_SCOPE;
4238             LOP(OP_DIE,XTERM);
4239
4240         case KEY_defined:
4241             UNI(OP_DEFINED);
4242
4243         case KEY_delete:
4244             UNI(OP_DELETE);
4245
4246         case KEY_dbmopen:
4247             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4248             LOP(OP_DBMOPEN,XTERM);
4249
4250         case KEY_dbmclose:
4251             UNI(OP_DBMCLOSE);
4252
4253         case KEY_dump:
4254             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4255             LOOPX(OP_DUMP);
4256
4257         case KEY_else:
4258             PREBLOCK(ELSE);
4259
4260         case KEY_elsif:
4261             yylval.ival = CopLINE(PL_curcop);
4262             OPERATOR(ELSIF);
4263
4264         case KEY_eq:
4265             Eop(OP_SEQ);
4266
4267         case KEY_exists:
4268             UNI(OP_EXISTS);
4269
4270         case KEY_exit:
4271             UNI(OP_EXIT);
4272
4273         case KEY_eval:
4274             s = skipspace(s);
4275             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4276             UNIBRACK(OP_ENTEREVAL);
4277
4278         case KEY_eof:
4279             UNI(OP_EOF);
4280
4281         case KEY_exp:
4282             UNI(OP_EXP);
4283
4284         case KEY_each:
4285             UNI(OP_EACH);
4286
4287         case KEY_exec:
4288             set_csh();
4289             LOP(OP_EXEC,XREF);
4290
4291         case KEY_endhostent:
4292             FUN0(OP_EHOSTENT);
4293
4294         case KEY_endnetent:
4295             FUN0(OP_ENETENT);
4296
4297         case KEY_endservent:
4298             FUN0(OP_ESERVENT);
4299
4300         case KEY_endprotoent:
4301             FUN0(OP_EPROTOENT);
4302
4303         case KEY_endpwent:
4304             FUN0(OP_EPWENT);
4305
4306         case KEY_endgrent:
4307             FUN0(OP_EGRENT);
4308
4309         case KEY_for:
4310         case KEY_foreach:
4311             yylval.ival = CopLINE(PL_curcop);
4312             s = skipspace(s);
4313             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4314                 char *p = s;
4315                 if ((PL_bufend - p) >= 3 &&
4316                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4317                     p += 2;
4318                 else if ((PL_bufend - p) >= 4 &&
4319                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4320                     p += 3;
4321                 p = skipspace(p);
4322                 if (isIDFIRST_lazy_if(p,UTF)) {
4323                     p = scan_ident(p, PL_bufend,
4324                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4325                     p = skipspace(p);
4326                 }
4327                 if (*p != '$')
4328                     Perl_croak(aTHX_ "Missing $ on loop variable");
4329             }
4330             OPERATOR(FOR);
4331
4332         case KEY_formline:
4333             LOP(OP_FORMLINE,XTERM);
4334
4335         case KEY_fork:
4336             FUN0(OP_FORK);
4337
4338         case KEY_fcntl:
4339             LOP(OP_FCNTL,XTERM);
4340
4341         case KEY_fileno:
4342             UNI(OP_FILENO);
4343
4344         case KEY_flock:
4345             LOP(OP_FLOCK,XTERM);
4346
4347         case KEY_gt:
4348             Rop(OP_SGT);
4349
4350         case KEY_ge:
4351             Rop(OP_SGE);
4352
4353         case KEY_grep:
4354             LOP(OP_GREPSTART, XREF);
4355
4356         case KEY_goto:
4357             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4358             LOOPX(OP_GOTO);
4359
4360         case KEY_gmtime:
4361             UNI(OP_GMTIME);
4362
4363         case KEY_getc:
4364             UNI(OP_GETC);
4365
4366         case KEY_getppid:
4367             FUN0(OP_GETPPID);
4368
4369         case KEY_getpgrp:
4370             UNI(OP_GETPGRP);
4371
4372         case KEY_getpriority:
4373             LOP(OP_GETPRIORITY,XTERM);
4374
4375         case KEY_getprotobyname:
4376             UNI(OP_GPBYNAME);
4377
4378         case KEY_getprotobynumber:
4379             LOP(OP_GPBYNUMBER,XTERM);
4380
4381         case KEY_getprotoent:
4382             FUN0(OP_GPROTOENT);
4383
4384         case KEY_getpwent:
4385             FUN0(OP_GPWENT);
4386
4387         case KEY_getpwnam:
4388             UNI(OP_GPWNAM);
4389
4390         case KEY_getpwuid:
4391             UNI(OP_GPWUID);
4392
4393         case KEY_getpeername:
4394             UNI(OP_GETPEERNAME);
4395
4396         case KEY_gethostbyname:
4397             UNI(OP_GHBYNAME);
4398
4399         case KEY_gethostbyaddr:
4400             LOP(OP_GHBYADDR,XTERM);
4401
4402         case KEY_gethostent:
4403             FUN0(OP_GHOSTENT);
4404
4405         case KEY_getnetbyname:
4406             UNI(OP_GNBYNAME);
4407
4408         case KEY_getnetbyaddr:
4409             LOP(OP_GNBYADDR,XTERM);
4410
4411         case KEY_getnetent:
4412             FUN0(OP_GNETENT);
4413
4414         case KEY_getservbyname:
4415             LOP(OP_GSBYNAME,XTERM);
4416
4417         case KEY_getservbyport:
4418             LOP(OP_GSBYPORT,XTERM);
4419
4420         case KEY_getservent:
4421             FUN0(OP_GSERVENT);
4422
4423         case KEY_getsockname:
4424             UNI(OP_GETSOCKNAME);
4425
4426         case KEY_getsockopt:
4427             LOP(OP_GSOCKOPT,XTERM);
4428
4429         case KEY_getgrent:
4430             FUN0(OP_GGRENT);
4431
4432         case KEY_getgrnam:
4433             UNI(OP_GGRNAM);
4434
4435         case KEY_getgrgid:
4436             UNI(OP_GGRGID);
4437
4438         case KEY_getlogin:
4439             FUN0(OP_GETLOGIN);
4440
4441         case KEY_glob:
4442             set_csh();
4443             LOP(OP_GLOB,XTERM);
4444
4445         case KEY_hex:
4446             UNI(OP_HEX);
4447
4448         case KEY_if:
4449             yylval.ival = CopLINE(PL_curcop);
4450             OPERATOR(IF);
4451
4452         case KEY_index:
4453             LOP(OP_INDEX,XTERM);
4454
4455         case KEY_int:
4456             UNI(OP_INT);
4457
4458         case KEY_ioctl:
4459             LOP(OP_IOCTL,XTERM);
4460
4461         case KEY_join:
4462             LOP(OP_JOIN,XTERM);
4463
4464         case KEY_keys:
4465             UNI(OP_KEYS);
4466
4467         case KEY_kill:
4468             LOP(OP_KILL,XTERM);
4469
4470         case KEY_last:
4471             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4472             LOOPX(OP_LAST);
4473
4474         case KEY_lc:
4475             UNI(OP_LC);
4476
4477         case KEY_lcfirst:
4478             UNI(OP_LCFIRST);
4479
4480         case KEY_local:
4481             yylval.ival = 0;
4482             OPERATOR(LOCAL);
4483
4484         case KEY_length:
4485             UNI(OP_LENGTH);
4486
4487         case KEY_lt:
4488             Rop(OP_SLT);
4489
4490         case KEY_le:
4491             Rop(OP_SLE);
4492
4493         case KEY_localtime:
4494             UNI(OP_LOCALTIME);
4495
4496         case KEY_log:
4497             UNI(OP_LOG);
4498
4499         case KEY_link:
4500             LOP(OP_LINK,XTERM);
4501
4502         case KEY_listen:
4503             LOP(OP_LISTEN,XTERM);
4504
4505         case KEY_lock:
4506             UNI(OP_LOCK);
4507
4508         case KEY_lstat:
4509             UNI(OP_LSTAT);
4510
4511         case KEY_m:
4512             s = scan_pat(s,OP_MATCH);
4513             TERM(sublex_start());
4514
4515         case KEY_map:
4516             LOP(OP_MAPSTART, XREF);
4517
4518         case KEY_mkdir:
4519             LOP(OP_MKDIR,XTERM);
4520
4521         case KEY_msgctl:
4522             LOP(OP_MSGCTL,XTERM);
4523
4524         case KEY_msgget:
4525             LOP(OP_MSGGET,XTERM);
4526
4527         case KEY_msgrcv:
4528             LOP(OP_MSGRCV,XTERM);
4529
4530         case KEY_msgsnd:
4531             LOP(OP_MSGSND,XTERM);
4532
4533         case KEY_our:
4534         case KEY_my:
4535             PL_in_my = tmp;
4536             s = skipspace(s);
4537             if (isIDFIRST_lazy_if(s,UTF)) {
4538                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4539                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4540                     goto really_sub;
4541                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4542                 if (!PL_in_my_stash) {
4543                     char tmpbuf[1024];
4544                     PL_bufptr = s;
4545                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4546                     yyerror(tmpbuf);
4547                 }
4548             }
4549             yylval.ival = 1;
4550             OPERATOR(MY);
4551
4552         case KEY_next:
4553             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4554             LOOPX(OP_NEXT);
4555
4556         case KEY_ne:
4557             Eop(OP_SNE);
4558
4559         case KEY_no:
4560             if (PL_expect != XSTATE)
4561                 yyerror("\"no\" not allowed in expression");
4562             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4563             s = force_version(s, FALSE);
4564             yylval.ival = 0;
4565             OPERATOR(USE);
4566
4567         case KEY_not:
4568             if (*s == '(' || (s = skipspace(s), *s == '('))
4569                 FUN1(OP_NOT);
4570             else
4571                 OPERATOR(NOTOP);
4572
4573         case KEY_open:
4574             s = skipspace(s);
4575             if (isIDFIRST_lazy_if(s,UTF)) {
4576                 char *t;
4577                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4578                 t = skipspace(d);
4579                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4580                     Perl_warner(aTHX_ WARN_PRECEDENCE,
4581                            "Precedence problem: open %.*s should be open(%.*s)",
4582                             d-s,s, d-s,s);
4583             }
4584             LOP(OP_OPEN,XTERM);
4585
4586         case KEY_or:
4587             yylval.ival = OP_OR;
4588             OPERATOR(OROP);
4589
4590         case KEY_ord:
4591             UNI(OP_ORD);
4592
4593         case KEY_oct:
4594             UNI(OP_OCT);
4595
4596         case KEY_opendir:
4597             LOP(OP_OPEN_DIR,XTERM);
4598
4599         case KEY_print:
4600             checkcomma(s,PL_tokenbuf,"filehandle");
4601             LOP(OP_PRINT,XREF);
4602
4603         case KEY_printf:
4604             checkcomma(s,PL_tokenbuf,"filehandle");
4605             LOP(OP_PRTF,XREF);
4606
4607         case KEY_prototype:
4608             UNI(OP_PROTOTYPE);
4609
4610         case KEY_push:
4611             LOP(OP_PUSH,XTERM);
4612
4613         case KEY_pop:
4614             UNI(OP_POP);
4615
4616         case KEY_pos:
4617             UNI(OP_POS);
4618
4619         case KEY_pack:
4620             LOP(OP_PACK,XTERM);
4621
4622         case KEY_package:
4623             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4624             OPERATOR(PACKAGE);
4625
4626         case KEY_pipe:
4627             LOP(OP_PIPE_OP,XTERM);
4628
4629         case KEY_q:
4630             s = scan_str(s,FALSE,FALSE);
4631             if (!s)
4632                 missingterm((char*)0);
4633             yylval.ival = OP_CONST;
4634             TERM(sublex_start());
4635
4636         case KEY_quotemeta:
4637             UNI(OP_QUOTEMETA);
4638
4639         case KEY_qw:
4640             s = scan_str(s,FALSE,FALSE);
4641             if (!s)
4642                 missingterm((char*)0);
4643             force_next(')');
4644             if (SvCUR(PL_lex_stuff)) {
4645                 OP *words = Nullop;
4646                 int warned = 0;
4647                 d = SvPV_force(PL_lex_stuff, len);
4648                 while (len) {
4649                     SV *sv;
4650                     for (; isSPACE(*d) && len; --len, ++d) ;
4651                     if (len) {
4652                         char *b = d;
4653                         if (!warned && ckWARN(WARN_QW)) {
4654                             for (; !isSPACE(*d) && len; --len, ++d) {
4655                                 if (*d == ',') {
4656                                     Perl_warner(aTHX_ WARN_QW,
4657                                         "Possible attempt to separate words with commas");
4658                                     ++warned;
4659                                 }
4660                                 else if (*d == '#') {
4661                                     Perl_warner(aTHX_ WARN_QW,
4662                                         "Possible attempt to put comments in qw() list");
4663                                     ++warned;
4664                                 }
4665                             }
4666                         }
4667                         else {
4668                             for (; !isSPACE(*d) && len; --len, ++d) ;
4669                         }
4670                         sv = newSVpvn(b, d-b);
4671                         if (DO_UTF8(PL_lex_stuff))
4672                             SvUTF8_on(sv);
4673                         words = append_elem(OP_LIST, words,
4674                                             newSVOP(OP_CONST, 0, tokeq(sv)));
4675                     }
4676                 }
4677                 if (words) {
4678                     PL_nextval[PL_nexttoke].opval = words;
4679                     force_next(THING);
4680                 }
4681             }
4682             if (PL_lex_stuff) {
4683                 SvREFCNT_dec(PL_lex_stuff);
4684                 PL_lex_stuff = Nullsv;
4685             }
4686             PL_expect = XTERM;
4687             TOKEN('(');
4688
4689         case KEY_qq:
4690             s = scan_str(s,FALSE,FALSE);
4691             if (!s)
4692                 missingterm((char*)0);
4693             yylval.ival = OP_STRINGIFY;
4694             if (SvIVX(PL_lex_stuff) == '\'')
4695                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4696             TERM(sublex_start());
4697
4698         case KEY_qr:
4699             s = scan_pat(s,OP_QR);
4700             TERM(sublex_start());
4701
4702         case KEY_qx:
4703             s = scan_str(s,FALSE,FALSE);
4704             if (!s)
4705                 missingterm((char*)0);
4706             yylval.ival = OP_BACKTICK;
4707             set_csh();
4708             TERM(sublex_start());
4709
4710         case KEY_return:
4711             OLDLOP(OP_RETURN);
4712
4713         case KEY_require:
4714             s = skipspace(s);
4715             if (isDIGIT(*s)) {
4716                 s = force_version(s, FALSE);
4717             }
4718             else if (*s != 'v' || !isDIGIT(s[1])
4719                     || (s = force_version(s, TRUE), *s == 'v'))
4720             {
4721                 *PL_tokenbuf = '\0';
4722                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4723                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4724                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4725                 else if (*s == '<')
4726                     yyerror("<> should be quotes");
4727             }
4728             UNI(OP_REQUIRE);
4729
4730         case KEY_reset:
4731             UNI(OP_RESET);
4732
4733         case KEY_redo:
4734             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4735             LOOPX(OP_REDO);
4736
4737         case KEY_rename:
4738             LOP(OP_RENAME,XTERM);
4739
4740         case KEY_rand:
4741             UNI(OP_RAND);
4742
4743         case KEY_rmdir:
4744             UNI(OP_RMDIR);
4745
4746         case KEY_rindex:
4747             LOP(OP_RINDEX,XTERM);
4748
4749         case KEY_read:
4750             LOP(OP_READ,XTERM);
4751
4752         case KEY_readdir:
4753             UNI(OP_READDIR);
4754
4755         case KEY_readline:
4756             set_csh();
4757             UNI(OP_READLINE);
4758
4759         case KEY_readpipe:
4760             set_csh();
4761             UNI(OP_BACKTICK);
4762
4763         case KEY_rewinddir:
4764             UNI(OP_REWINDDIR);
4765
4766         case KEY_recv:
4767             LOP(OP_RECV,XTERM);
4768
4769         case KEY_reverse:
4770             LOP(OP_REVERSE,XTERM);
4771
4772         case KEY_readlink:
4773             UNI(OP_READLINK);
4774
4775         case KEY_ref:
4776             UNI(OP_REF);
4777
4778         case KEY_s:
4779             s = scan_subst(s);
4780             if (yylval.opval)
4781                 TERM(sublex_start());
4782             else
4783                 TOKEN(1);       /* force error */
4784
4785         case KEY_chomp:
4786             UNI(OP_CHOMP);
4787
4788         case KEY_scalar:
4789             UNI(OP_SCALAR);
4790
4791         case KEY_select:
4792             LOP(OP_SELECT,XTERM);
4793
4794         case KEY_seek:
4795             LOP(OP_SEEK,XTERM);
4796
4797         case KEY_semctl:
4798             LOP(OP_SEMCTL,XTERM);
4799
4800         case KEY_semget:
4801             LOP(OP_SEMGET,XTERM);
4802
4803         case KEY_semop:
4804             LOP(OP_SEMOP,XTERM);
4805
4806         case KEY_send:
4807             LOP(OP_SEND,XTERM);
4808
4809         case KEY_setpgrp:
4810             LOP(OP_SETPGRP,XTERM);
4811
4812         case KEY_setpriority:
4813             LOP(OP_SETPRIORITY,XTERM);
4814
4815         case KEY_sethostent:
4816             UNI(OP_SHOSTENT);
4817
4818         case KEY_setnetent:
4819             UNI(OP_SNETENT);
4820
4821         case KEY_setservent:
4822             UNI(OP_SSERVENT);
4823
4824         case KEY_setprotoent:
4825             UNI(OP_SPROTOENT);
4826
4827         case KEY_setpwent:
4828             FUN0(OP_SPWENT);
4829
4830         case KEY_setgrent:
4831             FUN0(OP_SGRENT);
4832
4833         case KEY_seekdir:
4834             LOP(OP_SEEKDIR,XTERM);
4835
4836         case KEY_setsockopt:
4837             LOP(OP_SSOCKOPT,XTERM);
4838
4839         case KEY_shift:
4840             UNI(OP_SHIFT);
4841
4842         case KEY_shmctl:
4843             LOP(OP_SHMCTL,XTERM);
4844
4845         case KEY_shmget:
4846             LOP(OP_SHMGET,XTERM);
4847
4848         case KEY_shmread:
4849             LOP(OP_SHMREAD,XTERM);
4850
4851         case KEY_shmwrite:
4852             LOP(OP_SHMWRITE,XTERM);
4853
4854         case KEY_shutdown:
4855             LOP(OP_SHUTDOWN,XTERM);
4856
4857         case KEY_sin:
4858             UNI(OP_SIN);
4859
4860         case KEY_sleep:
4861             UNI(OP_SLEEP);
4862
4863         case KEY_socket:
4864             LOP(OP_SOCKET,XTERM);
4865
4866         case KEY_socketpair:
4867             LOP(OP_SOCKPAIR,XTERM);
4868
4869         case KEY_sort:
4870             checkcomma(s,PL_tokenbuf,"subroutine name");
4871             s = skipspace(s);
4872             if (*s == ';' || *s == ')')         /* probably a close */
4873                 Perl_croak(aTHX_ "sort is now a reserved word");
4874             PL_expect = XTERM;
4875             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4876             LOP(OP_SORT,XREF);
4877
4878         case KEY_split:
4879             LOP(OP_SPLIT,XTERM);
4880
4881         case KEY_sprintf:
4882             LOP(OP_SPRINTF,XTERM);
4883
4884         case KEY_splice:
4885             LOP(OP_SPLICE,XTERM);
4886
4887         case KEY_sqrt:
4888             UNI(OP_SQRT);
4889
4890         case KEY_srand:
4891             UNI(OP_SRAND);
4892
4893         case KEY_stat:
4894             UNI(OP_STAT);
4895
4896         case KEY_study:
4897             UNI(OP_STUDY);
4898
4899         case KEY_substr:
4900             LOP(OP_SUBSTR,XTERM);
4901
4902         case KEY_format:
4903         case KEY_sub:
4904           really_sub:
4905             {
4906                 char tmpbuf[sizeof PL_tokenbuf];
4907                 SSize_t tboffset = 0;
4908                 expectation attrful;
4909                 bool have_name, have_proto, bad_proto;
4910                 int key = tmp;
4911
4912                 s = skipspace(s);
4913
4914                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4915                     (*s == ':' && s[1] == ':'))
4916                 {
4917                     PL_expect = XBLOCK;
4918                     attrful = XATTRBLOCK;
4919                     /* remember buffer pos'n for later force_word */
4920                     tboffset = s - PL_oldbufptr;
4921                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4922                     if (strchr(tmpbuf, ':'))
4923                         sv_setpv(PL_subname, tmpbuf);
4924                     else {
4925                         sv_setsv(PL_subname,PL_curstname);
4926                         sv_catpvn(PL_subname,"::",2);
4927                         sv_catpvn(PL_subname,tmpbuf,len);
4928                     }
4929                     s = skipspace(d);
4930                     have_name = TRUE;
4931                 }
4932                 else {
4933                     if (key == KEY_my)
4934                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
4935                     PL_expect = XTERMBLOCK;
4936                     attrful = XATTRTERM;
4937                     sv_setpv(PL_subname,"?");
4938                     have_name = FALSE;
4939                 }
4940
4941                 if (key == KEY_format) {
4942                     if (*s == '=')
4943                         PL_lex_formbrack = PL_lex_brackets + 1;
4944                     if (have_name)
4945                         (void) force_word(PL_oldbufptr + tboffset, WORD,
4946                                           FALSE, TRUE, TRUE);
4947                     OPERATOR(FORMAT);
4948                 }
4949
4950                 /* Look for a prototype */
4951                 if (*s == '(') {
4952                     char *p;
4953
4954                     s = scan_str(s,FALSE,FALSE);
4955                     if (!s)
4956                         Perl_croak(aTHX_ "Prototype not terminated");
4957                     /* strip spaces and check for bad characters */
4958                     d = SvPVX(PL_lex_stuff);
4959                     tmp = 0;
4960                     bad_proto = FALSE;
4961                     for (p = d; *p; ++p) {
4962                         if (!isSPACE(*p)) {
4963                             d[tmp++] = *p;
4964                             if (!strchr("$@%*;[]&\\", *p))
4965                                 bad_proto = TRUE;
4966                         }
4967                     }
4968                     d[tmp] = '\0';
4969                     if (bad_proto && ckWARN(WARN_SYNTAX))
4970                         Perl_warner(aTHX_ WARN_SYNTAX,
4971                                     "Illegal character in prototype for %s : %s",
4972                                     SvPVX(PL_subname), d);
4973                     SvCUR(PL_lex_stuff) = tmp;
4974                     have_proto = TRUE;
4975
4976                     s = skipspace(s);
4977                 }
4978                 else
4979                     have_proto = FALSE;
4980
4981                 if (*s == ':' && s[1] != ':')
4982                     PL_expect = attrful;
4983
4984                 if (have_proto) {
4985                     PL_nextval[PL_nexttoke].opval =
4986                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4987                     PL_lex_stuff = Nullsv;
4988                     force_next(THING);
4989                 }
4990                 if (!have_name) {
4991                     sv_setpv(PL_subname,"__ANON__");
4992                     TOKEN(ANONSUB);
4993                 }
4994                 (void) force_word(PL_oldbufptr + tboffset, WORD,
4995                                   FALSE, TRUE, TRUE);
4996                 if (key == KEY_my)
4997                     TOKEN(MYSUB);
4998                 TOKEN(SUB);
4999             }
5000
5001         case KEY_system:
5002             set_csh();
5003             LOP(OP_SYSTEM,XREF);
5004
5005         case KEY_symlink:
5006             LOP(OP_SYMLINK,XTERM);
5007
5008         case KEY_syscall:
5009             LOP(OP_SYSCALL,XTERM);
5010
5011         case KEY_sysopen:
5012             LOP(OP_SYSOPEN,XTERM);
5013
5014         case KEY_sysseek:
5015             LOP(OP_SYSSEEK,XTERM);
5016
5017         case KEY_sysread:
5018             LOP(OP_SYSREAD,XTERM);
5019
5020         case KEY_syswrite:
5021             LOP(OP_SYSWRITE,XTERM);
5022
5023         case KEY_tr:
5024             s = scan_trans(s);
5025             TERM(sublex_start());
5026
5027         case KEY_tell:
5028             UNI(OP_TELL);
5029
5030         case KEY_telldir:
5031             UNI(OP_TELLDIR);
5032
5033         case KEY_tie:
5034             LOP(OP_TIE,XTERM);
5035
5036         case KEY_tied:
5037             UNI(OP_TIED);
5038
5039         case KEY_time:
5040             FUN0(OP_TIME);
5041
5042         case KEY_times:
5043             FUN0(OP_TMS);
5044
5045         case KEY_truncate:
5046             LOP(OP_TRUNCATE,XTERM);
5047
5048         case KEY_uc:
5049             UNI(OP_UC);
5050
5051         case KEY_ucfirst:
5052             UNI(OP_UCFIRST);
5053
5054         case KEY_untie:
5055             UNI(OP_UNTIE);
5056
5057         case KEY_until:
5058             yylval.ival = CopLINE(PL_curcop);
5059             OPERATOR(UNTIL);
5060
5061         case KEY_unless:
5062             yylval.ival = CopLINE(PL_curcop);
5063             OPERATOR(UNLESS);
5064
5065         case KEY_unlink:
5066             LOP(OP_UNLINK,XTERM);
5067
5068         case KEY_undef:
5069             UNI(OP_UNDEF);
5070
5071         case KEY_unpack:
5072             LOP(OP_UNPACK,XTERM);
5073
5074         case KEY_utime:
5075             LOP(OP_UTIME,XTERM);
5076
5077         case KEY_umask:
5078             UNI(OP_UMASK);
5079
5080         case KEY_unshift:
5081             LOP(OP_UNSHIFT,XTERM);
5082
5083         case KEY_use:
5084             if (PL_expect != XSTATE)
5085                 yyerror("\"use\" not allowed in expression");
5086             s = skipspace(s);
5087             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5088                 s = force_version(s, TRUE);
5089                 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5090                     PL_nextval[PL_nexttoke].opval = Nullop;
5091                     force_next(WORD);
5092                 }
5093                 else if (*s == 'v') {
5094                     s = force_word(s,WORD,FALSE,TRUE,FALSE);
5095                     s = force_version(s, FALSE);
5096                 }
5097             }
5098             else {
5099                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5100                 s = force_version(s, FALSE);
5101             }
5102             yylval.ival = 1;
5103             OPERATOR(USE);
5104
5105         case KEY_values:
5106             UNI(OP_VALUES);
5107
5108         case KEY_vec:
5109             LOP(OP_VEC,XTERM);
5110
5111         case KEY_while:
5112             yylval.ival = CopLINE(PL_curcop);
5113             OPERATOR(WHILE);
5114
5115         case KEY_warn:
5116             PL_hints |= HINT_BLOCK_SCOPE;
5117             LOP(OP_WARN,XTERM);
5118
5119         case KEY_wait:
5120             FUN0(OP_WAIT);
5121
5122         case KEY_waitpid:
5123             LOP(OP_WAITPID,XTERM);
5124
5125         case KEY_wantarray:
5126             FUN0(OP_WANTARRAY);
5127
5128         case KEY_write:
5129 #ifdef EBCDIC
5130         {
5131             char ctl_l[2];
5132             ctl_l[0] = toCTRL('L');
5133             ctl_l[1] = '\0';
5134             gv_fetchpv(ctl_l,TRUE, SVt_PV);
5135         }
5136 #else
5137             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
5138 #endif
5139             UNI(OP_ENTERWRITE);
5140
5141         case KEY_x:
5142             if (PL_expect == XOPERATOR)
5143                 Mop(OP_REPEAT);
5144             check_uni();
5145             goto just_a_word;
5146
5147         case KEY_xor:
5148             yylval.ival = OP_XOR;
5149             OPERATOR(OROP);
5150
5151         case KEY_y:
5152             s = scan_trans(s);
5153             TERM(sublex_start());
5154         }
5155     }}
5156 }
5157 #ifdef __SC__
5158 #pragma segment Main
5159 #endif
5160
5161 static int
5162 S_pending_ident(pTHX)
5163 {
5164     register char *d;
5165     register I32 tmp;
5166     /* pit holds the identifier we read and pending_ident is reset */
5167     char pit = PL_pending_ident;
5168     PL_pending_ident = 0;
5169
5170     DEBUG_T({ PerlIO_printf(Perl_debug_log,
5171           "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5172
5173     /* if we're in a my(), we can't allow dynamics here.
5174        $foo'bar has already been turned into $foo::bar, so
5175        just check for colons.
5176
5177        if it's a legal name, the OP is a PADANY.
5178     */
5179     if (PL_in_my) {
5180         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
5181             if (strchr(PL_tokenbuf,':'))
5182                 yyerror(Perl_form(aTHX_ "No package name allowed for "
5183                                   "variable %s in \"our\"",
5184                                   PL_tokenbuf));
5185             tmp = pad_allocmy(PL_tokenbuf);
5186         }
5187         else {
5188             if (strchr(PL_tokenbuf,':'))
5189                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5190
5191             yylval.opval = newOP(OP_PADANY, 0);
5192             yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
5193             return PRIVATEREF;
5194         }
5195     }
5196
5197     /*
5198        build the ops for accesses to a my() variable.
5199
5200        Deny my($a) or my($b) in a sort block, *if* $a or $b is
5201        then used in a comparison.  This catches most, but not
5202        all cases.  For instance, it catches
5203            sort { my($a); $a <=> $b }
5204        but not
5205            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5206        (although why you'd do that is anyone's guess).
5207     */
5208
5209     if (!strchr(PL_tokenbuf,':')) {
5210 #ifdef USE_5005THREADS
5211         /* Check for single character per-thread SVs */
5212         if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
5213             && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
5214             && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
5215         {
5216             yylval.opval = newOP(OP_THREADSV, 0);
5217             yylval.opval->op_targ = tmp;
5218             return PRIVATEREF;
5219         }
5220 #endif /* USE_5005THREADS */
5221         if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
5222             SV *namesv = AvARRAY(PL_comppad_name)[tmp];
5223             /* might be an "our" variable" */
5224             if (SvFLAGS(namesv) & SVpad_OUR) {
5225                 /* build ops for a bareword */
5226                 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
5227                 sv_catpvn(sym, "::", 2);
5228                 sv_catpv(sym, PL_tokenbuf+1);
5229                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5230                 yylval.opval->op_private = OPpCONST_ENTERED;
5231                 gv_fetchpv(SvPVX(sym),
5232                     (PL_in_eval
5233                         ? (GV_ADDMULTI | GV_ADDINEVAL)
5234                         : GV_ADDMULTI
5235                     ),
5236                     ((PL_tokenbuf[0] == '$') ? SVt_PV
5237                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5238                      : SVt_PVHV));
5239                 return WORD;
5240             }
5241
5242             /* if it's a sort block and they're naming $a or $b */
5243             if (PL_last_lop_op == OP_SORT &&
5244                 PL_tokenbuf[0] == '$' &&
5245                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5246                 && !PL_tokenbuf[2])
5247             {
5248                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5249                      d < PL_bufend && *d != '\n';
5250                      d++)
5251                 {
5252                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5253                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5254                               PL_tokenbuf);
5255                     }
5256                 }
5257             }
5258
5259             yylval.opval = newOP(OP_PADANY, 0);
5260             yylval.opval->op_targ = tmp;
5261             return PRIVATEREF;
5262         }
5263     }
5264
5265     /*
5266        Whine if they've said @foo in a doublequoted string,
5267        and @foo isn't a variable we can find in the symbol
5268        table.
5269     */
5270     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5271         GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5272         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5273              && ckWARN(WARN_AMBIGUOUS))
5274         {
5275             /* Downgraded from fatal to warning 20000522 mjd */
5276             Perl_warner(aTHX_ WARN_AMBIGUOUS,
5277                         "Possible unintended interpolation of %s in string",
5278                          PL_tokenbuf);
5279         }
5280     }
5281
5282     /* build ops for a bareword */
5283     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5284     yylval.opval->op_private = OPpCONST_ENTERED;
5285     gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5286                ((PL_tokenbuf[0] == '$') ? SVt_PV
5287                 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5288                 : SVt_PVHV));
5289     return WORD;
5290 }
5291
5292 I32
5293 Perl_keyword(pTHX_ register char *d, I32 len)
5294 {
5295     switch (*d) {
5296     case '_':
5297         if (d[1] == '_') {
5298             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
5299             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
5300             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
5301             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
5302             if (strEQ(d,"__END__"))             return KEY___END__;
5303         }
5304         break;
5305     case 'A':
5306         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
5307         break;
5308     case 'a':
5309         switch (len) {
5310         case 3:
5311             if (strEQ(d,"and"))                 return -KEY_and;
5312             if (strEQ(d,"abs"))                 return -KEY_abs;
5313             break;
5314         case 5:
5315             if (strEQ(d,"alarm"))               return -KEY_alarm;
5316             if (strEQ(d,"atan2"))               return -KEY_atan2;
5317             break;
5318         case 6:
5319             if (strEQ(d,"accept"))              return -KEY_accept;
5320             break;
5321         }
5322         break;
5323     case 'B':
5324         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
5325         break;
5326     case 'b':
5327         if (strEQ(d,"bless"))                   return -KEY_bless;
5328         if (strEQ(d,"bind"))                    return -KEY_bind;
5329         if (strEQ(d,"binmode"))                 return -KEY_binmode;
5330         break;
5331     case 'C':
5332         if (strEQ(d,"CORE"))                    return -KEY_CORE;
5333         if (strEQ(d,"CHECK"))                   return KEY_CHECK;
5334         break;
5335     case 'c':
5336         switch (len) {
5337         case 3:
5338             if (strEQ(d,"cmp"))                 return -KEY_cmp;
5339             if (strEQ(d,"chr"))                 return -KEY_chr;
5340             if (strEQ(d,"cos"))                 return -KEY_cos;
5341             break;
5342         case 4:
5343             if (strEQ(d,"chop"))                return -KEY_chop;
5344             break;
5345         case 5:
5346             if (strEQ(d,"close"))               return -KEY_close;
5347             if (strEQ(d,"chdir"))               return -KEY_chdir;
5348             if (strEQ(d,"chomp"))               return -KEY_chomp;
5349             if (strEQ(d,"chmod"))               return -KEY_chmod;
5350             if (strEQ(d,"chown"))               return -KEY_chown;
5351             if (strEQ(d,"crypt"))               return -KEY_crypt;
5352             break;
5353         case 6:
5354             if (strEQ(d,"chroot"))              return -KEY_chroot;
5355             if (strEQ(d,"caller"))              return -KEY_caller;
5356             break;
5357         case 7:
5358             if (strEQ(d,"connect"))             return -KEY_connect;
5359             break;
5360         case 8:
5361             if (strEQ(d,"closedir"))            return -KEY_closedir;
5362             if (strEQ(d,"continue"))            return -KEY_continue;
5363             break;
5364         }
5365         break;
5366     case 'D':
5367         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
5368         break;
5369     case 'd':
5370         switch (len) {
5371         case 2:
5372             if (strEQ(d,"do"))                  return KEY_do;
5373             break;
5374         case 3:
5375             if (strEQ(d,"die"))                 return -KEY_die;
5376             break;
5377         case 4:
5378             if (strEQ(d,"dump"))                return -KEY_dump;
5379             break;
5380         case 6:
5381             if (strEQ(d,"delete"))              return KEY_delete;
5382             break;
5383         case 7:
5384             if (strEQ(d,"defined"))             return KEY_defined;
5385             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
5386             break;
5387         case 8:
5388             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
5389             break;
5390         }
5391         break;
5392     case 'E':
5393         if (strEQ(d,"END"))                     return KEY_END;
5394         break;
5395     case 'e':
5396         switch (len) {
5397         case 2:
5398             if (strEQ(d,"eq"))                  return -KEY_eq;
5399             break;
5400         case 3:
5401             if (strEQ(d,"eof"))                 return -KEY_eof;
5402             if (strEQ(d,"exp"))                 return -KEY_exp;
5403             break;
5404         case 4:
5405             if (strEQ(d,"else"))                return KEY_else;
5406             if (strEQ(d,"exit"))                return -KEY_exit;
5407             if (strEQ(d,"eval"))                return KEY_eval;
5408             if (strEQ(d,"exec"))                return -KEY_exec;
5409            if (strEQ(d,"each"))                return -KEY_each;
5410             break;
5411         case 5:
5412             if (strEQ(d,"elsif"))               return KEY_elsif;
5413             break;
5414         case 6:
5415             if (strEQ(d,"exists"))              return KEY_exists;
5416             if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5417             break;
5418         case 8:
5419             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
5420             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
5421             break;
5422         case 9:
5423             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
5424             break;
5425         case 10:
5426             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
5427             if (strEQ(d,"endservent"))          return -KEY_endservent;
5428             break;
5429         case 11:
5430             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
5431             break;
5432         }
5433         break;
5434     case 'f':
5435         switch (len) {
5436         case 3:
5437             if (strEQ(d,"for"))                 return KEY_for;
5438             break;
5439         case 4:
5440             if (strEQ(d,"fork"))                return -KEY_fork;
5441             break;
5442         case 5:
5443             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
5444             if (strEQ(d,"flock"))               return -KEY_flock;
5445             break;
5446         case 6:
5447             if (strEQ(d,"format"))              return KEY_format;
5448             if (strEQ(d,"fileno"))              return -KEY_fileno;
5449             break;
5450         case 7:
5451             if (strEQ(d,"foreach"))             return KEY_foreach;
5452             break;
5453         case 8:
5454             if (strEQ(d,"formline"))            return -KEY_formline;
5455             break;
5456         }
5457         break;
5458     case 'g':
5459         if (strnEQ(d,"get",3)) {
5460             d += 3;
5461             if (*d == 'p') {
5462                 switch (len) {
5463                 case 7:
5464                     if (strEQ(d,"ppid"))        return -KEY_getppid;
5465                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
5466                     break;
5467                 case 8:
5468                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
5469                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
5470                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
5471                     break;
5472                 case 11:
5473                     if (strEQ(d,"peername"))    return -KEY_getpeername;
5474                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
5475                     if (strEQ(d,"priority"))    return -KEY_getpriority;
5476                     break;
5477                 case 14:
5478                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5479                     break;
5480                 case 16:
5481                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5482                     break;
5483                 }
5484             }
5485             else if (*d == 'h') {
5486                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
5487                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
5488                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
5489             }
5490             else if (*d == 'n') {
5491                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
5492                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
5493                 if (strEQ(d,"netent"))          return -KEY_getnetent;
5494             }
5495             else if (*d == 's') {
5496                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
5497                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
5498                 if (strEQ(d,"servent"))         return -KEY_getservent;
5499                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
5500                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
5501             }
5502             else if (*d == 'g') {
5503                 if (strEQ(d,"grent"))           return -KEY_getgrent;
5504                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
5505                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
5506             }
5507             else if (*d == 'l') {
5508                 if (strEQ(d,"login"))           return -KEY_getlogin;
5509             }
5510             else if (strEQ(d,"c"))              return -KEY_getc;
5511             break;
5512         }
5513         switch (len) {
5514         case 2:
5515             if (strEQ(d,"gt"))                  return -KEY_gt;
5516             if (strEQ(d,"ge"))                  return -KEY_ge;
5517             break;
5518         case 4:
5519             if (strEQ(d,"grep"))                return KEY_grep;
5520             if (strEQ(d,"goto"))                return KEY_goto;
5521             if (strEQ(d,"glob"))                return KEY_glob;
5522             break;
5523         case 6:
5524             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
5525             break;
5526         }
5527         break;
5528     case 'h':
5529         if (strEQ(d,"hex"))                     return -KEY_hex;
5530         break;
5531     case 'I':
5532         if (strEQ(d,"INIT"))                    return KEY_INIT;
5533         break;
5534     case 'i':
5535         switch (len) {
5536         case 2:
5537             if (strEQ(d,"if"))                  return KEY_if;
5538             break;
5539         case 3:
5540             if (strEQ(d,"int"))                 return -KEY_int;
5541             break;
5542         case 5:
5543             if (strEQ(d,"index"))               return -KEY_index;
5544             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
5545             break;
5546         }
5547         break;
5548     case 'j':
5549         if (strEQ(d,"join"))                    return -KEY_join;
5550         break;
5551     case 'k':
5552         if (len == 4) {
5553            if (strEQ(d,"keys"))                return -KEY_keys;
5554             if (strEQ(d,"kill"))                return -KEY_kill;
5555         }
5556         break;
5557     case 'l':
5558         switch (len) {
5559         case 2:
5560             if (strEQ(d,"lt"))                  return -KEY_lt;
5561             if (strEQ(d,"le"))                  return -KEY_le;
5562             if (strEQ(d,"lc"))                  return -KEY_lc;
5563             break;
5564         case 3:
5565             if (strEQ(d,"log"))                 return -KEY_log;
5566             break;
5567         case 4:
5568             if (strEQ(d,"last"))                return KEY_last;
5569             if (strEQ(d,"link"))                return -KEY_link;
5570             if (strEQ(d,"lock"))                return -KEY_lock;
5571             break;
5572         case 5:
5573             if (strEQ(d,"local"))               return KEY_local;
5574             if (strEQ(d,"lstat"))               return -KEY_lstat;
5575             break;
5576         case 6:
5577             if (strEQ(d,"length"))              return -KEY_length;
5578             if (strEQ(d,"listen"))              return -KEY_listen;
5579             break;
5580         case 7:
5581             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
5582             break;
5583         case 9:
5584             if (strEQ(d,"localtime"))           return -KEY_localtime;
5585             break;
5586         }
5587         break;
5588     case 'm':
5589         switch (len) {
5590         case 1:                                 return KEY_m;
5591         case 2:
5592             if (strEQ(d,"my"))                  return KEY_my;
5593             break;
5594         case 3:
5595             if (strEQ(d,"map"))                 return KEY_map;
5596             break;
5597         case 5:
5598             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
5599             break;
5600         case 6:
5601             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
5602             if (strEQ(d,"msgget"))              return -KEY_msgget;
5603             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
5604             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
5605             break;
5606         }
5607         break;
5608     case 'n':
5609         if (strEQ(d,"next"))                    return KEY_next;
5610         if (strEQ(d,"ne"))                      return -KEY_ne;
5611         if (strEQ(d,"not"))                     return -KEY_not;
5612         if (strEQ(d,"no"))                      return KEY_no;
5613         break;
5614     case 'o':
5615         switch (len) {
5616         case 2:
5617             if (strEQ(d,"or"))                  return -KEY_or;
5618             break;
5619         case 3:
5620             if (strEQ(d,"ord"))                 return -KEY_ord;
5621             if (strEQ(d,"oct"))                 return -KEY_oct;
5622             if (strEQ(d,"our"))                 return KEY_our;
5623             break;
5624         case 4:
5625             if (strEQ(d,"open"))                return -KEY_open;
5626             break;
5627         case 7:
5628             if (strEQ(d,"opendir"))             return -KEY_opendir;
5629             break;
5630         }
5631         break;
5632     case 'p':
5633         switch (len) {
5634         case 3:
5635            if (strEQ(d,"pop"))                 return -KEY_pop;
5636             if (strEQ(d,"pos"))                 return KEY_pos;
5637             break;
5638         case 4:
5639            if (strEQ(d,"push"))                return -KEY_push;
5640             if (strEQ(d,"pack"))                return -KEY_pack;
5641             if (strEQ(d,"pipe"))                return -KEY_pipe;
5642             break;
5643         case 5:
5644             if (strEQ(d,"print"))               return KEY_print;
5645             break;
5646         case 6:
5647             if (strEQ(d,"printf"))              return KEY_printf;
5648             break;
5649         case 7:
5650             if (strEQ(d,"package"))             return KEY_package;
5651             break;
5652         case 9:
5653             if (strEQ(d,"prototype"))           return KEY_prototype;
5654         }
5655         break;
5656     case 'q':
5657         if (len <= 2) {
5658             if (strEQ(d,"q"))                   return KEY_q;
5659             if (strEQ(d,"qr"))                  return KEY_qr;
5660             if (strEQ(d,"qq"))                  return KEY_qq;
5661             if (strEQ(d,"qw"))                  return KEY_qw;
5662             if (strEQ(d,"qx"))                  return KEY_qx;
5663         }
5664         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
5665         break;
5666     case 'r':
5667         switch (len) {
5668         case 3:
5669             if (strEQ(d,"ref"))                 return -KEY_ref;
5670             break;
5671         case 4:
5672             if (strEQ(d,"read"))                return -KEY_read;
5673             if (strEQ(d,"rand"))                return -KEY_rand;
5674             if (strEQ(d,"recv"))                return -KEY_recv;
5675             if (strEQ(d,"redo"))                return KEY_redo;
5676             break;
5677         case 5:
5678             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
5679             if (strEQ(d,"reset"))               return -KEY_reset;
5680             break;
5681         case 6:
5682             if (strEQ(d,"return"))              return KEY_return;
5683             if (strEQ(d,"rename"))              return -KEY_rename;
5684             if (strEQ(d,"rindex"))              return -KEY_rindex;
5685             break;
5686         case 7:
5687             if (strEQ(d,"require"))             return KEY_require;
5688             if (strEQ(d,"reverse"))             return -KEY_reverse;
5689             if (strEQ(d,"readdir"))             return -KEY_readdir;
5690             break;
5691         case 8:
5692             if (strEQ(d,"readlink"))            return -KEY_readlink;
5693             if (strEQ(d,"readline"))            return -KEY_readline;
5694             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5695             break;
5696         case 9:
5697             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5698             break;
5699         }
5700         break;
5701     case 's':
5702         switch (d[1]) {
5703         case 0:                                 return KEY_s;
5704         case 'c':
5705             if (strEQ(d,"scalar"))              return KEY_scalar;
5706             break;
5707         case 'e':
5708             switch (len) {
5709             case 4:
5710                 if (strEQ(d,"seek"))            return -KEY_seek;
5711                 if (strEQ(d,"send"))            return -KEY_send;
5712                 break;
5713             case 5:
5714                 if (strEQ(d,"semop"))           return -KEY_semop;
5715                 break;
5716             case 6:
5717                 if (strEQ(d,"select"))          return -KEY_select;
5718                 if (strEQ(d,"semctl"))          return -KEY_semctl;
5719                 if (strEQ(d,"semget"))          return -KEY_semget;
5720                 break;
5721             case 7:
5722                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
5723                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
5724                 break;
5725             case 8:
5726                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
5727                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
5728                 break;
5729             case 9:
5730                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
5731                 break;
5732             case 10:
5733                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
5734                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
5735                 if (strEQ(d,"setservent"))      return -KEY_setservent;
5736                 break;
5737             case 11:
5738                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
5739                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
5740                 break;
5741             }
5742             break;
5743         case 'h':
5744             switch (len) {
5745             case 5:
5746                if (strEQ(d,"shift"))           return -KEY_shift;
5747                 break;
5748             case 6:
5749                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
5750                 if (strEQ(d,"shmget"))          return -KEY_shmget;
5751                 break;
5752             case 7:
5753                 if (strEQ(d,"shmread"))         return -KEY_shmread;
5754                 break;
5755             case 8:
5756                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
5757                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
5758                 break;
5759             }
5760             break;
5761         case 'i':
5762             if (strEQ(d,"sin"))                 return -KEY_sin;
5763             break;
5764         case 'l':
5765             if (strEQ(d,"sleep"))               return -KEY_sleep;
5766             break;
5767         case 'o':
5768             if (strEQ(d,"sort"))                return KEY_sort;
5769             if (strEQ(d,"socket"))              return -KEY_socket;
5770             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
5771             break;
5772         case 'p':
5773             if (strEQ(d,"split"))               return KEY_split;
5774             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
5775            if (strEQ(d,"splice"))              return -KEY_splice;
5776             break;
5777         case 'q':
5778             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
5779             break;
5780         case 'r':
5781             if (strEQ(d,"srand"))               return -KEY_srand;
5782             break;
5783         case 't':
5784             if (strEQ(d,"stat"))                return -KEY_stat;
5785             if (strEQ(d,"study"))               return KEY_study;
5786             break;
5787         case 'u':
5788             if (strEQ(d,"substr"))              return -KEY_substr;
5789             if (strEQ(d,"sub"))                 return KEY_sub;
5790             break;
5791         case 'y':
5792             switch (len) {
5793             case 6:
5794                 if (strEQ(d,"system"))          return -KEY_system;
5795                 break;
5796             case 7:
5797                 if (strEQ(d,"symlink"))         return -KEY_symlink;
5798                 if (strEQ(d,"syscall"))         return -KEY_syscall;
5799                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
5800                 if (strEQ(d,"sysread"))         return -KEY_sysread;
5801                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
5802                 break;
5803             case 8:
5804                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
5805                 break;
5806             }
5807             break;
5808         }
5809         break;
5810     case 't':
5811         switch (len) {
5812         case 2:
5813             if (strEQ(d,"tr"))                  return KEY_tr;
5814             break;
5815         case 3:
5816             if (strEQ(d,"tie"))                 return KEY_tie;
5817             break;
5818         case 4:
5819             if (strEQ(d,"tell"))                return -KEY_tell;
5820             if (strEQ(d,"tied"))                return KEY_tied;
5821             if (strEQ(d,"time"))                return -KEY_time;
5822             break;
5823         case 5:
5824             if (strEQ(d,"times"))               return -KEY_times;
5825             break;
5826         case 7:
5827             if (strEQ(d,"telldir"))             return -KEY_telldir;
5828             break;
5829         case 8:
5830             if (strEQ(d,"truncate"))            return -KEY_truncate;
5831             break;
5832         }
5833         break;
5834     case 'u':
5835         switch (len) {
5836         case 2:
5837             if (strEQ(d,"uc"))                  return -KEY_uc;
5838             break;
5839         case 3:
5840             if (strEQ(d,"use"))                 return KEY_use;
5841             break;
5842         case 5:
5843             if (strEQ(d,"undef"))               return KEY_undef;
5844             if (strEQ(d,"until"))               return KEY_until;
5845             if (strEQ(d,"untie"))               return KEY_untie;
5846             if (strEQ(d,"utime"))               return -KEY_utime;
5847             if (strEQ(d,"umask"))               return -KEY_umask;
5848             break;
5849         case 6:
5850             if (strEQ(d,"unless"))              return KEY_unless;
5851             if (strEQ(d,"unpack"))              return -KEY_unpack;
5852             if (strEQ(d,"unlink"))              return -KEY_unlink;
5853             break;
5854         case 7:
5855            if (strEQ(d,"unshift"))             return -KEY_unshift;
5856             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
5857             break;
5858         }
5859         break;
5860     case 'v':
5861         if (strEQ(d,"values"))                  return -KEY_values;
5862         if (strEQ(d,"vec"))                     return -KEY_vec;
5863         break;
5864     case 'w':
5865         switch (len) {
5866         case 4:
5867             if (strEQ(d,"warn"))                return -KEY_warn;
5868             if (strEQ(d,"wait"))                return -KEY_wait;
5869             break;
5870         case 5:
5871             if (strEQ(d,"while"))               return KEY_while;
5872             if (strEQ(d,"write"))               return -KEY_write;
5873             break;
5874         case 7:
5875             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
5876             break;
5877         case 9:
5878             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
5879             break;
5880         }
5881         break;
5882     case 'x':
5883         if (len == 1)                           return -KEY_x;
5884         if (strEQ(d,"xor"))                     return -KEY_xor;
5885         break;
5886     case 'y':
5887         if (len == 1)                           return KEY_y;
5888         break;
5889     case 'z':
5890         break;
5891     }
5892     return 0;
5893 }
5894
5895 STATIC void
5896 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5897 {
5898     char *w;
5899
5900     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
5901         if (ckWARN(WARN_SYNTAX)) {
5902             int level = 1;
5903             for (w = s+2; *w && level; w++) {
5904                 if (*w == '(')
5905                     ++level;
5906                 else if (*w == ')')
5907                     --level;
5908             }
5909             if (*w)
5910                 for (; *w && isSPACE(*w); w++) ;
5911             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
5912                 Perl_warner(aTHX_ WARN_SYNTAX,
5913                             "%s (...) interpreted as function",name);
5914         }
5915     }
5916     while (s < PL_bufend && isSPACE(*s))
5917         s++;
5918     if (*s == '(')
5919         s++;
5920     while (s < PL_bufend && isSPACE(*s))
5921         s++;
5922     if (isIDFIRST_lazy_if(s,UTF)) {
5923         w = s++;
5924         while (isALNUM_lazy_if(s,UTF))
5925             s++;
5926         while (s < PL_bufend && isSPACE(*s))
5927             s++;
5928         if (*s == ',') {
5929             int kw;
5930             *s = '\0';
5931             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5932             *s = ',';
5933             if (kw)
5934                 return;
5935             Perl_croak(aTHX_ "No comma allowed after %s", what);
5936         }
5937     }
5938 }
5939
5940 /* Either returns sv, or mortalizes sv and returns a new SV*.
5941    Best used as sv=new_constant(..., sv, ...).
5942    If s, pv are NULL, calls subroutine with one argument,
5943    and type is used with error messages only. */
5944
5945 STATIC SV *
5946 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5947                const char *type)
5948 {
5949     dSP;
5950     HV *table = GvHV(PL_hintgv);                 /* ^H */
5951     SV *res;
5952     SV **cvp;
5953     SV *cv, *typesv;
5954     const char *why1, *why2, *why3;
5955
5956     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5957         SV *msg;
5958
5959         why2 = strEQ(key,"charnames")
5960                ? "(possibly a missing \"use charnames ...\")"
5961                : "";
5962         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5963                             (type ? type: "undef"), why2);
5964
5965         /* This is convoluted and evil ("goto considered harmful")
5966          * but I do not understand the intricacies of all the different
5967          * failure modes of %^H in here.  The goal here is to make
5968          * the most probable error message user-friendly. --jhi */
5969
5970         goto msgdone;
5971
5972     report:
5973         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5974                             (type ? type: "undef"), why1, why2, why3);
5975     msgdone:
5976         yyerror(SvPVX(msg));
5977         SvREFCNT_dec(msg);
5978         return sv;
5979     }
5980     cvp = hv_fetch(table, key, strlen(key), FALSE);
5981     if (!cvp || !SvOK(*cvp)) {
5982         why1 = "$^H{";
5983         why2 = key;
5984         why3 = "} is not defined";
5985         goto report;
5986     }
5987     sv_2mortal(sv);                     /* Parent created it permanently */
5988     cv = *cvp;
5989     if (!pv && s)
5990         pv = sv_2mortal(newSVpvn(s, len));
5991     if (type && pv)
5992         typesv = sv_2mortal(newSVpv(type, 0));
5993     else
5994         typesv = &PL_sv_undef;
5995
5996     PUSHSTACKi(PERLSI_OVERLOAD);
5997     ENTER ;
5998     SAVETMPS;
5999
6000     PUSHMARK(SP) ;
6001     EXTEND(sp, 3);
6002     if (pv)
6003         PUSHs(pv);
6004     PUSHs(sv);
6005     if (pv)
6006         PUSHs(typesv);
6007     PUTBACK;
6008     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
6009
6010     SPAGAIN ;
6011
6012     /* Check the eval first */
6013     if (!PL_in_eval && SvTRUE(ERRSV)) {
6014         STRLEN n_a;
6015         sv_catpv(ERRSV, "Propagated");
6016         yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6017         (void)POPs;
6018         res = SvREFCNT_inc(sv);
6019     }
6020     else {
6021         res = POPs;
6022         (void)SvREFCNT_inc(res);
6023     }
6024
6025     PUTBACK ;
6026     FREETMPS ;
6027     LEAVE ;
6028     POPSTACK;
6029
6030     if (!SvOK(res)) {
6031         why1 = "Call to &{$^H{";
6032         why2 = key;
6033         why3 = "}} did not return a defined value";
6034         sv = res;
6035         goto report;
6036     }
6037
6038     return res;
6039 }
6040
6041 STATIC char *
6042 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6043 {
6044     register char *d = dest;
6045     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
6046     for (;;) {
6047         if (d >= e)
6048             Perl_croak(aTHX_ ident_too_long);
6049         if (isALNUM(*s))        /* UTF handled below */
6050             *d++ = *s++;
6051         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6052             *d++ = ':';
6053             *d++ = ':';
6054             s++;
6055         }
6056         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6057             *d++ = *s++;
6058             *d++ = *s++;
6059         }
6060         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6061             char *t = s + UTF8SKIP(s);
6062             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6063                 t += UTF8SKIP(t);
6064             if (d + (t - s) > e)
6065                 Perl_croak(aTHX_ ident_too_long);
6066             Copy(s, d, t - s, char);
6067             d += t - s;
6068             s = t;
6069         }
6070         else {
6071             *d = '\0';
6072             *slp = d - dest;
6073             return s;
6074         }
6075     }
6076 }
6077
6078 STATIC char *
6079 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6080 {
6081     register char *d;
6082     register char *e;
6083     char *bracket = 0;
6084     char funny = *s++;
6085
6086     if (isSPACE(*s))
6087         s = skipspace(s);
6088     d = dest;
6089     e = d + destlen - 3;        /* two-character token, ending NUL */
6090     if (isDIGIT(*s)) {
6091         while (isDIGIT(*s)) {
6092             if (d >= e)
6093                 Perl_croak(aTHX_ ident_too_long);
6094             *d++ = *s++;
6095         }
6096     }
6097     else {
6098         for (;;) {
6099             if (d >= e)
6100                 Perl_croak(aTHX_ ident_too_long);
6101             if (isALNUM(*s))    /* UTF handled below */
6102                 *d++ = *s++;
6103             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6104                 *d++ = ':';
6105                 *d++ = ':';
6106                 s++;
6107             }
6108             else if (*s == ':' && s[1] == ':') {
6109                 *d++ = *s++;
6110                 *d++ = *s++;
6111             }
6112             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6113                 char *t = s + UTF8SKIP(s);
6114                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6115                     t += UTF8SKIP(t);
6116                 if (d + (t - s) > e)
6117                     Perl_croak(aTHX_ ident_too_long);
6118                 Copy(s, d, t - s, char);
6119                 d += t - s;
6120                 s = t;
6121             }
6122             else
6123                 break;
6124         }
6125     }
6126     *d = '\0';
6127     d = dest;
6128     if (*d) {
6129         if (PL_lex_state != LEX_NORMAL)
6130             PL_lex_state = LEX_INTERPENDMAYBE;
6131         return s;
6132     }
6133     if (*s == '$' && s[1] &&
6134         (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6135     {
6136         return s;
6137     }
6138     if (*s == '{') {
6139         bracket = s;
6140         s++;
6141     }
6142     else if (ck_uni)
6143         check_uni();
6144     if (s < send)
6145         *d = *s++;
6146     d[1] = '\0';
6147     if (*d == '^' && *s && isCONTROLVAR(*s)) {
6148         *d = toCTRL(*s);
6149         s++;
6150     }
6151     if (bracket) {
6152         if (isSPACE(s[-1])) {
6153             while (s < send) {
6154                 char ch = *s++;
6155                 if (!SPACE_OR_TAB(ch)) {
6156                     *d = ch;
6157                     break;
6158                 }
6159             }
6160         }
6161         if (isIDFIRST_lazy_if(d,UTF)) {
6162             d++;
6163             if (UTF) {
6164                 e = s;
6165                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6166                     e += UTF8SKIP(e);
6167                     while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6168                         e += UTF8SKIP(e);
6169                 }
6170                 Copy(s, d, e - s, char);
6171                 d += e - s;
6172                 s = e;
6173             }
6174             else {
6175                 while ((isALNUM(*s) || *s == ':') && d < e)
6176                     *d++ = *s++;
6177                 if (d >= e)
6178                     Perl_croak(aTHX_ ident_too_long);
6179             }
6180             *d = '\0';
6181             while (s < send && SPACE_OR_TAB(*s)) s++;
6182             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6183                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6184                     const char *brack = *s == '[' ? "[...]" : "{...}";
6185                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
6186                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6187                         funny, dest, brack, funny, dest, brack);
6188                 }
6189                 bracket++;
6190                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6191                 return s;
6192             }
6193         }
6194         /* Handle extended ${^Foo} variables
6195          * 1999-02-27 mjd-perl-patch@plover.com */
6196         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6197                  && isALNUM(*s))
6198         {
6199             d++;
6200             while (isALNUM(*s) && d < e) {
6201                 *d++ = *s++;
6202             }
6203             if (d >= e)
6204                 Perl_croak(aTHX_ ident_too_long);
6205             *d = '\0';
6206         }
6207         if (*s == '}') {
6208             s++;
6209             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6210                 PL_lex_state = LEX_INTERPEND;
6211             if (funny == '#')
6212                 funny = '@';
6213             if (PL_lex_state == LEX_NORMAL) {
6214                 if (ckWARN(WARN_AMBIGUOUS) &&
6215                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6216                 {
6217                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
6218                         "Ambiguous use of %c{%s} resolved to %c%s",
6219                         funny, dest, funny, dest);
6220                 }
6221             }
6222         }
6223         else {
6224             s = bracket;                /* let the parser handle it */
6225             *dest = '\0';
6226         }
6227     }
6228     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6229         PL_lex_state = LEX_INTERPEND;
6230     return s;
6231 }
6232
6233 void
6234 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6235 {
6236     if (ch == 'i')
6237         *pmfl |= PMf_FOLD;
6238     else if (ch == 'g')
6239         *pmfl |= PMf_GLOBAL;
6240     else if (ch == 'c')
6241         *pmfl |= PMf_CONTINUE;
6242     else if (ch == 'o')
6243         *pmfl |= PMf_KEEP;
6244     else if (ch == 'm')
6245         *pmfl |= PMf_MULTILINE;
6246     else if (ch == 's')
6247         *pmfl |= PMf_SINGLELINE;
6248     else if (ch == 'x')
6249         *pmfl |= PMf_EXTENDED;
6250 }
6251
6252 STATIC char *
6253 S_scan_pat(pTHX_ char *start, I32 type)
6254 {
6255     PMOP *pm;
6256     char *s;
6257
6258     s = scan_str(start,FALSE,FALSE);
6259     if (!s)
6260         Perl_croak(aTHX_ "Search pattern not terminated");
6261
6262     pm = (PMOP*)newPMOP(type, 0);
6263     if (PL_multi_open == '?')
6264         pm->op_pmflags |= PMf_ONCE;
6265     if(type == OP_QR) {
6266         while (*s && strchr("iomsx", *s))
6267             pmflag(&pm->op_pmflags,*s++);
6268     }
6269     else {
6270         while (*s && strchr("iogcmsx", *s))
6271             pmflag(&pm->op_pmflags,*s++);
6272     }
6273     pm->op_pmpermflags = pm->op_pmflags;
6274
6275     PL_lex_op = (OP*)pm;
6276     yylval.ival = OP_MATCH;
6277     return s;
6278 }
6279
6280 STATIC char *
6281 S_scan_subst(pTHX_ char *start)
6282 {
6283     register char *s;
6284     register PMOP *pm;
6285     I32 first_start;
6286     I32 es = 0;
6287
6288     yylval.ival = OP_NULL;
6289
6290     s = scan_str(start,FALSE,FALSE);
6291
6292     if (!s)
6293         Perl_croak(aTHX_ "Substitution pattern not terminated");
6294
6295     if (s[-1] == PL_multi_open)
6296         s--;
6297
6298     first_start = PL_multi_start;
6299     s = scan_str(s,FALSE,FALSE);
6300     if (!s) {
6301         if (PL_lex_stuff) {
6302             SvREFCNT_dec(PL_lex_stuff);
6303             PL_lex_stuff = Nullsv;
6304         }
6305         Perl_croak(aTHX_ "Substitution replacement not terminated");
6306     }
6307     PL_multi_start = first_start;       /* so whole substitution is taken together */
6308
6309     pm = (PMOP*)newPMOP(OP_SUBST, 0);
6310     while (*s) {
6311         if (*s == 'e') {
6312             s++;
6313             es++;
6314         }
6315         else if (strchr("iogcmsx", *s))
6316             pmflag(&pm->op_pmflags,*s++);
6317         else
6318             break;
6319     }
6320
6321     if (es) {
6322         SV *repl;
6323         PL_sublex_info.super_bufptr = s;
6324         PL_sublex_info.super_bufend = PL_bufend;
6325         PL_multi_end = 0;
6326         pm->op_pmflags |= PMf_EVAL;
6327         repl = newSVpvn("",0);
6328         while (es-- > 0)
6329             sv_catpv(repl, es ? "eval " : "do ");
6330         sv_catpvn(repl, "{ ", 2);
6331         sv_catsv(repl, PL_lex_repl);
6332         sv_catpvn(repl, " };", 2);
6333         SvEVALED_on(repl);
6334         SvREFCNT_dec(PL_lex_repl);
6335         PL_lex_repl = repl;
6336     }
6337
6338     pm->op_pmpermflags = pm->op_pmflags;
6339     PL_lex_op = (OP*)pm;
6340     yylval.ival = OP_SUBST;
6341     return s;
6342 }
6343
6344 STATIC char *
6345 S_scan_trans(pTHX_ char *start)
6346 {
6347     register char* s;
6348     OP *o;
6349     short *tbl;
6350     I32 squash;
6351     I32 del;
6352     I32 complement;
6353
6354     yylval.ival = OP_NULL;
6355
6356     s = scan_str(start,FALSE,FALSE);
6357     if (!s)
6358         Perl_croak(aTHX_ "Transliteration pattern not terminated");
6359     if (s[-1] == PL_multi_open)
6360         s--;
6361
6362     s = scan_str(s,FALSE,FALSE);
6363     if (!s) {
6364         if (PL_lex_stuff) {
6365             SvREFCNT_dec(PL_lex_stuff);
6366             PL_lex_stuff = Nullsv;
6367         }
6368         Perl_croak(aTHX_ "Transliteration replacement not terminated");
6369     }
6370
6371     complement = del = squash = 0;
6372     while (strchr("cds", *s)) {
6373         if (*s == 'c')
6374             complement = OPpTRANS_COMPLEMENT;
6375         else if (*s == 'd')
6376             del = OPpTRANS_DELETE;
6377         else if (*s == 's')
6378             squash = OPpTRANS_SQUASH;
6379         s++;
6380     }
6381
6382     New(803, tbl, complement&&!del?258:256, short);
6383     o = newPVOP(OP_TRANS, 0, (char*)tbl);
6384     o->op_private = del|squash|complement|
6385       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6386       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
6387
6388     PL_lex_op = o;
6389     yylval.ival = OP_TRANS;
6390     return s;
6391 }
6392
6393 STATIC char *
6394 S_scan_heredoc(pTHX_ register char *s)
6395 {
6396     SV *herewas;
6397     I32 op_type = OP_SCALAR;
6398     I32 len;
6399     SV *tmpstr;
6400     char term;
6401     register char *d;
6402     register char *e;
6403     char *peek;
6404     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6405
6406     s += 2;
6407     d = PL_tokenbuf;
6408     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6409     if (!outer)
6410         *d++ = '\n';
6411     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6412     if (*peek && strchr("`'\"",*peek)) {
6413         s = peek;
6414         term = *s++;
6415         s = delimcpy(d, e, s, PL_bufend, term, &len);
6416         d += len;
6417         if (s < PL_bufend)
6418             s++;
6419     }
6420     else {
6421         if (*s == '\\')
6422             s++, term = '\'';
6423         else
6424             term = '"';
6425         if (!isALNUM_lazy_if(s,UTF))
6426             deprecate("bare << to mean <<\"\"");
6427         for (; isALNUM_lazy_if(s,UTF); s++) {
6428             if (d < e)
6429                 *d++ = *s;
6430         }
6431     }
6432     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6433         Perl_croak(aTHX_ "Delimiter for here document is too long");
6434     *d++ = '\n';
6435     *d = '\0';
6436     len = d - PL_tokenbuf;
6437 #ifndef PERL_STRICT_CR
6438     d = strchr(s, '\r');
6439     if (d) {
6440         char *olds = s;
6441         s = d;
6442         while (s < PL_bufend) {
6443             if (*s == '\r') {
6444                 *d++ = '\n';
6445                 if (*++s == '\n')
6446                     s++;
6447             }
6448             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
6449                 *d++ = *s++;
6450                 s++;
6451             }
6452             else
6453                 *d++ = *s++;
6454         }
6455         *d = '\0';
6456         PL_bufend = d;
6457         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6458         s = olds;
6459     }
6460 #endif
6461     d = "\n";
6462     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6463         herewas = newSVpvn(s,PL_bufend-s);
6464     else
6465         s--, herewas = newSVpvn(s,d-s);
6466     s += SvCUR(herewas);
6467
6468     tmpstr = NEWSV(87,79);
6469     sv_upgrade(tmpstr, SVt_PVIV);
6470     if (term == '\'') {
6471         op_type = OP_CONST;
6472         SvIVX(tmpstr) = -1;
6473     }
6474     else if (term == '`') {
6475         op_type = OP_BACKTICK;
6476         SvIVX(tmpstr) = '\\';
6477     }
6478
6479     CLINE;
6480     PL_multi_start = CopLINE(PL_curcop);
6481     PL_multi_open = PL_multi_close = '<';
6482     term = *PL_tokenbuf;
6483     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6484         char *bufptr = PL_sublex_info.super_bufptr;
6485         char *bufend = PL_sublex_info.super_bufend;
6486         char *olds = s - SvCUR(herewas);
6487         s = strchr(bufptr, '\n');
6488         if (!s)
6489             s = bufend;
6490         d = s;
6491         while (s < bufend &&
6492           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6493             if (*s++ == '\n')
6494                 CopLINE_inc(PL_curcop);
6495         }
6496         if (s >= bufend) {
6497             CopLINE_set(PL_curcop, PL_multi_start);
6498             missingterm(PL_tokenbuf);
6499         }
6500         sv_setpvn(herewas,bufptr,d-bufptr+1);
6501         sv_setpvn(tmpstr,d+1,s-d);
6502         s += len - 1;
6503         sv_catpvn(herewas,s,bufend-s);
6504         (void)strcpy(bufptr,SvPVX(herewas));
6505
6506         s = olds;
6507         goto retval;
6508     }
6509     else if (!outer) {
6510         d = s;
6511         while (s < PL_bufend &&
6512           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6513             if (*s++ == '\n')
6514                 CopLINE_inc(PL_curcop);
6515         }
6516         if (s >= PL_bufend) {
6517             CopLINE_set(PL_curcop, PL_multi_start);
6518             missingterm(PL_tokenbuf);
6519         }
6520         sv_setpvn(tmpstr,d+1,s-d);
6521         s += len - 1;
6522         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6523
6524         sv_catpvn(herewas,s,PL_bufend-s);
6525         sv_setsv(PL_linestr,herewas);
6526         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6527         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6528         PL_last_lop = PL_last_uni = Nullch;
6529     }
6530     else
6531         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
6532     while (s >= PL_bufend) {    /* multiple line string? */
6533         if (!outer ||
6534          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6535             CopLINE_set(PL_curcop, PL_multi_start);
6536             missingterm(PL_tokenbuf);
6537         }
6538         CopLINE_inc(PL_curcop);
6539         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6540         PL_last_lop = PL_last_uni = Nullch;
6541 #ifndef PERL_STRICT_CR
6542         if (PL_bufend - PL_linestart >= 2) {
6543             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6544                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6545             {
6546                 PL_bufend[-2] = '\n';
6547                 PL_bufend--;
6548                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6549             }
6550             else if (PL_bufend[-1] == '\r')
6551                 PL_bufend[-1] = '\n';
6552         }
6553         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6554             PL_bufend[-1] = '\n';
6555 #endif
6556         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6557             SV *sv = NEWSV(88,0);
6558
6559             sv_upgrade(sv, SVt_PVMG);
6560             sv_setsv(sv,PL_linestr);
6561             (void)SvIOK_on(sv);
6562             SvIVX(sv) = 0;
6563             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6564         }
6565         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6566             s = PL_bufend - 1;
6567             *s = ' ';
6568             sv_catsv(PL_linestr,herewas);
6569             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6570         }
6571         else {
6572             s = PL_bufend;
6573             sv_catsv(tmpstr,PL_linestr);
6574         }
6575     }
6576     s++;
6577 retval:
6578     PL_multi_end = CopLINE(PL_curcop);
6579     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6580         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6581         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6582     }
6583     SvREFCNT_dec(herewas);
6584     if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6585         SvUTF8_on(tmpstr);
6586     PL_lex_stuff = tmpstr;
6587     yylval.ival = op_type;
6588     return s;
6589 }
6590
6591 /* scan_inputsymbol
6592    takes: current position in input buffer
6593    returns: new position in input buffer
6594    side-effects: yylval and lex_op are set.
6595
6596    This code handles:
6597
6598    <>           read from ARGV
6599    <FH>         read from filehandle
6600    <pkg::FH>    read from package qualified filehandle
6601    <pkg'FH>     read from package qualified filehandle
6602    <$fh>        read from filehandle in $fh
6603    <*.h>        filename glob
6604
6605 */
6606
6607 STATIC char *
6608 S_scan_inputsymbol(pTHX_ char *start)
6609 {
6610     register char *s = start;           /* current position in buffer */
6611     register char *d;
6612     register char *e;
6613     char *end;
6614     I32 len;
6615
6616     d = PL_tokenbuf;                    /* start of temp holding space */
6617     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
6618     end = strchr(s, '\n');
6619     if (!end)
6620         end = PL_bufend;
6621     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
6622
6623     /* die if we didn't have space for the contents of the <>,
6624        or if it didn't end, or if we see a newline
6625     */
6626
6627     if (len >= sizeof PL_tokenbuf)
6628         Perl_croak(aTHX_ "Excessively long <> operator");
6629     if (s >= end)
6630         Perl_croak(aTHX_ "Unterminated <> operator");
6631
6632     s++;
6633
6634     /* check for <$fh>
6635        Remember, only scalar variables are interpreted as filehandles by
6636        this code.  Anything more complex (e.g., <$fh{$num}>) will be
6637        treated as a glob() call.
6638        This code makes use of the fact that except for the $ at the front,
6639        a scalar variable and a filehandle look the same.
6640     */
6641     if (*d == '$' && d[1]) d++;
6642
6643     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6644     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6645         d++;
6646
6647     /* If we've tried to read what we allow filehandles to look like, and
6648        there's still text left, then it must be a glob() and not a getline.
6649        Use scan_str to pull out the stuff between the <> and treat it
6650        as nothing more than a string.
6651     */
6652
6653     if (d - PL_tokenbuf != len) {
6654         yylval.ival = OP_GLOB;
6655         set_csh();
6656         s = scan_str(start,FALSE,FALSE);
6657         if (!s)
6658            Perl_croak(aTHX_ "Glob not terminated");
6659         return s;
6660     }
6661     else {
6662         bool readline_overriden = FALSE;
6663         GV *gv_readline = Nullgv;
6664         GV **gvp;
6665         /* we're in a filehandle read situation */
6666         d = PL_tokenbuf;
6667
6668         /* turn <> into <ARGV> */
6669         if (!len)
6670             (void)strcpy(d,"ARGV");
6671
6672         /* Check whether readline() is overriden */
6673         if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
6674                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
6675                 ||
6676                 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
6677                 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
6678                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
6679             readline_overriden = TRUE;
6680
6681         /* if <$fh>, create the ops to turn the variable into a
6682            filehandle
6683         */
6684         if (*d == '$') {
6685             I32 tmp;
6686
6687             /* try to find it in the pad for this block, otherwise find
6688                add symbol table ops
6689             */
6690             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6691                 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
6692                 if (SvFLAGS(namesv) & SVpad_OUR) {
6693                     SV *sym = sv_2mortal(newSVpv(HvNAME(GvSTASH(namesv)),0));
6694                     sv_catpvn(sym, "::", 2);
6695                     sv_catpv(sym, d+1);
6696                     d = SvPVX(sym);
6697                     goto intro_sym;
6698                 }
6699                 else {
6700                     OP *o = newOP(OP_PADSV, 0);
6701                     o->op_targ = tmp;
6702                     PL_lex_op = readline_overriden
6703                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6704                                 append_elem(OP_LIST, o,
6705                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
6706                         : (OP*)newUNOP(OP_READLINE, 0, o);
6707                 }
6708             }
6709             else {
6710                 GV *gv;
6711                 ++d;
6712 intro_sym:
6713                 gv = gv_fetchpv(d,
6714                                 (PL_in_eval
6715                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
6716                                  : GV_ADDMULTI),
6717                                 SVt_PV);
6718                 PL_lex_op = readline_overriden
6719                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6720                             append_elem(OP_LIST,
6721                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
6722                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6723                     : (OP*)newUNOP(OP_READLINE, 0,
6724                             newUNOP(OP_RV2SV, 0,
6725                                 newGVOP(OP_GV, 0, gv)));
6726             }
6727             PL_lex_op->op_flags |= OPf_SPECIAL;
6728             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6729             yylval.ival = OP_NULL;
6730         }
6731
6732         /* If it's none of the above, it must be a literal filehandle
6733            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6734         else {
6735             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6736             PL_lex_op = readline_overriden
6737                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6738                         append_elem(OP_LIST,
6739                             newGVOP(OP_GV, 0, gv),
6740                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6741                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6742             yylval.ival = OP_NULL;
6743         }
6744     }
6745
6746     return s;
6747 }
6748
6749
6750 /* scan_str
6751    takes: start position in buffer
6752           keep_quoted preserve \ on the embedded delimiter(s)
6753           keep_delims preserve the delimiters around the string
6754    returns: position to continue reading from buffer
6755    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6756         updates the read buffer.
6757
6758    This subroutine pulls a string out of the input.  It is called for:
6759         q               single quotes           q(literal text)
6760         '               single quotes           'literal text'
6761         qq              double quotes           qq(interpolate $here please)
6762         "               double quotes           "interpolate $here please"
6763         qx              backticks               qx(/bin/ls -l)
6764         `               backticks               `/bin/ls -l`
6765         qw              quote words             @EXPORT_OK = qw( func() $spam )
6766         m//             regexp match            m/this/
6767         s///            regexp substitute       s/this/that/
6768         tr///           string transliterate    tr/this/that/
6769         y///            string transliterate    y/this/that/
6770         ($*@)           sub prototypes          sub foo ($)
6771         (stuff)         sub attr parameters     sub foo : attr(stuff)
6772         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6773
6774    In most of these cases (all but <>, patterns and transliterate)
6775    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6776    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6777    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6778    calls scan_str().
6779
6780    It skips whitespace before the string starts, and treats the first
6781    character as the delimiter.  If the delimiter is one of ([{< then
6782    the corresponding "close" character )]}> is used as the closing
6783    delimiter.  It allows quoting of delimiters, and if the string has
6784    balanced delimiters ([{<>}]) it allows nesting.
6785
6786    On success, the SV with the resulting string is put into lex_stuff or,
6787    if that is already non-NULL, into lex_repl. The second case occurs only
6788    when parsing the RHS of the special constructs s/// and tr/// (y///).
6789    For convenience, the terminating delimiter character is stuffed into
6790    SvIVX of the SV.
6791 */
6792
6793 STATIC char *
6794 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6795 {
6796     SV *sv;                             /* scalar value: string */
6797     char *tmps;                         /* temp string, used for delimiter matching */
6798     register char *s = start;           /* current position in the buffer */
6799     register char term;                 /* terminating character */
6800     register char *to;                  /* current position in the sv's data */
6801     I32 brackets = 1;                   /* bracket nesting level */
6802     bool has_utf8 = FALSE;              /* is there any utf8 content? */
6803
6804     /* skip space before the delimiter */
6805     if (isSPACE(*s))
6806         s = skipspace(s);
6807
6808     /* mark where we are, in case we need to report errors */
6809     CLINE;
6810
6811     /* after skipping whitespace, the next character is the terminator */
6812     term = *s;
6813     if (!UTF8_IS_INVARIANT((U8)term) && UTF)
6814         has_utf8 = TRUE;
6815
6816     /* mark where we are */
6817     PL_multi_start = CopLINE(PL_curcop);
6818     PL_multi_open = term;
6819
6820     /* find corresponding closing delimiter */
6821     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6822         term = tmps[5];
6823     PL_multi_close = term;
6824
6825     /* create a new SV to hold the contents.  87 is leak category, I'm
6826        assuming.  79 is the SV's initial length.  What a random number. */
6827     sv = NEWSV(87,79);
6828     sv_upgrade(sv, SVt_PVIV);
6829     SvIVX(sv) = term;
6830     (void)SvPOK_only(sv);               /* validate pointer */
6831
6832     /* move past delimiter and try to read a complete string */
6833     if (keep_delims)
6834         sv_catpvn(sv, s, 1);
6835     s++;
6836     for (;;) {
6837         /* extend sv if need be */
6838         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6839         /* set 'to' to the next character in the sv's string */
6840         to = SvPVX(sv)+SvCUR(sv);
6841
6842         /* if open delimiter is the close delimiter read unbridle */
6843         if (PL_multi_open == PL_multi_close) {
6844             for (; s < PL_bufend; s++,to++) {
6845                 /* embedded newlines increment the current line number */
6846                 if (*s == '\n' && !PL_rsfp)
6847                     CopLINE_inc(PL_curcop);
6848                 /* handle quoted delimiters */
6849                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6850                     if (!keep_quoted && s[1] == term)
6851                         s++;
6852                 /* any other quotes are simply copied straight through */
6853                     else
6854                         *to++ = *s++;
6855                 }
6856                 /* terminate when run out of buffer (the for() condition), or
6857                    have found the terminator */
6858                 else if (*s == term)
6859                     break;
6860                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6861                     has_utf8 = TRUE;
6862                 *to = *s;
6863             }
6864         }
6865
6866         /* if the terminator isn't the same as the start character (e.g.,
6867            matched brackets), we have to allow more in the quoting, and
6868            be prepared for nested brackets.
6869         */
6870         else {
6871             /* read until we run out of string, or we find the terminator */
6872             for (; s < PL_bufend; s++,to++) {
6873                 /* embedded newlines increment the line count */
6874                 if (*s == '\n' && !PL_rsfp)
6875                     CopLINE_inc(PL_curcop);
6876                 /* backslashes can escape the open or closing characters */
6877                 if (*s == '\\' && s+1 < PL_bufend) {
6878                     if (!keep_quoted &&
6879                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6880                         s++;
6881                     else
6882                         *to++ = *s++;
6883                 }
6884                 /* allow nested opens and closes */
6885                 else if (*s == PL_multi_close && --brackets <= 0)
6886                     break;
6887                 else if (*s == PL_multi_open)
6888                     brackets++;
6889                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6890                     has_utf8 = TRUE;
6891                 *to = *s;
6892             }
6893         }
6894         /* terminate the copied string and update the sv's end-of-string */
6895         *to = '\0';
6896         SvCUR_set(sv, to - SvPVX(sv));
6897
6898         /*
6899          * this next chunk reads more into the buffer if we're not done yet
6900          */
6901
6902         if (s < PL_bufend)
6903             break;              /* handle case where we are done yet :-) */
6904
6905 #ifndef PERL_STRICT_CR
6906         if (to - SvPVX(sv) >= 2) {
6907             if ((to[-2] == '\r' && to[-1] == '\n') ||
6908                 (to[-2] == '\n' && to[-1] == '\r'))
6909             {
6910                 to[-2] = '\n';
6911                 to--;
6912                 SvCUR_set(sv, to - SvPVX(sv));
6913             }
6914             else if (to[-1] == '\r')
6915                 to[-1] = '\n';
6916         }
6917         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6918             to[-1] = '\n';
6919 #endif
6920
6921         /* if we're out of file, or a read fails, bail and reset the current
6922            line marker so we can report where the unterminated string began
6923         */
6924         if (!PL_rsfp ||
6925          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6926             sv_free(sv);
6927             CopLINE_set(PL_curcop, PL_multi_start);
6928             return Nullch;
6929         }
6930         /* we read a line, so increment our line counter */
6931         CopLINE_inc(PL_curcop);
6932
6933         /* update debugger info */
6934         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6935             SV *sv = NEWSV(88,0);
6936
6937             sv_upgrade(sv, SVt_PVMG);
6938             sv_setsv(sv,PL_linestr);
6939             (void)SvIOK_on(sv);
6940             SvIVX(sv) = 0;
6941             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6942         }
6943
6944         /* having changed the buffer, we must update PL_bufend */
6945         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6946         PL_last_lop = PL_last_uni = Nullch;
6947     }
6948
6949     /* at this point, we have successfully read the delimited string */
6950
6951     if (keep_delims)
6952         sv_catpvn(sv, s, 1);
6953     if (has_utf8)
6954         SvUTF8_on(sv);
6955     PL_multi_end = CopLINE(PL_curcop);
6956     s++;
6957
6958     /* if we allocated too much space, give some back */
6959     if (SvCUR(sv) + 5 < SvLEN(sv)) {
6960         SvLEN_set(sv, SvCUR(sv) + 1);
6961         Renew(SvPVX(sv), SvLEN(sv), char);
6962     }
6963
6964     /* decide whether this is the first or second quoted string we've read
6965        for this op
6966     */
6967
6968     if (PL_lex_stuff)
6969         PL_lex_repl = sv;
6970     else
6971         PL_lex_stuff = sv;
6972     return s;
6973 }
6974
6975 /*
6976   scan_num
6977   takes: pointer to position in buffer
6978   returns: pointer to new position in buffer
6979   side-effects: builds ops for the constant in yylval.op
6980
6981   Read a number in any of the formats that Perl accepts:
6982
6983   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
6984   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
6985   0b[01](_?[01])*
6986   0[0-7](_?[0-7])*
6987   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
6988
6989   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6990   thing it reads.
6991
6992   If it reads a number without a decimal point or an exponent, it will
6993   try converting the number to an integer and see if it can do so
6994   without loss of precision.
6995 */
6996
6997 char *
6998 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
6999 {
7000     register char *s = start;           /* current position in buffer */
7001     register char *d;                   /* destination in temp buffer */
7002     register char *e;                   /* end of temp buffer */
7003     NV nv;                              /* number read, as a double */
7004     SV *sv = Nullsv;                    /* place to put the converted number */
7005     bool floatit;                       /* boolean: int or float? */
7006     char *lastub = 0;                   /* position of last underbar */
7007     static char number_too_long[] = "Number too long";
7008
7009     /* We use the first character to decide what type of number this is */
7010
7011     switch (*s) {
7012     default:
7013       Perl_croak(aTHX_ "panic: scan_num");
7014
7015     /* if it starts with a 0, it could be an octal number, a decimal in
7016        0.13 disguise, or a hexadecimal number, or a binary number. */
7017     case '0':
7018         {
7019           /* variables:
7020              u          holds the "number so far"
7021              shift      the power of 2 of the base
7022                         (hex == 4, octal == 3, binary == 1)
7023              overflowed was the number more than we can hold?
7024
7025              Shift is used when we add a digit.  It also serves as an "are
7026              we in octal/hex/binary?" indicator to disallow hex characters
7027              when in octal mode.
7028            */
7029             NV n = 0.0;
7030             UV u = 0;
7031             I32 shift;
7032             bool overflowed = FALSE;
7033             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7034             static char* bases[5] = { "", "binary", "", "octal",
7035                                       "hexadecimal" };
7036             static char* Bases[5] = { "", "Binary", "", "Octal",
7037                                       "Hexadecimal" };
7038             static char *maxima[5] = { "",
7039                                        "0b11111111111111111111111111111111",
7040                                        "",
7041                                        "037777777777",
7042                                        "0xffffffff" };
7043             char *base, *Base, *max;
7044
7045             /* check for hex */
7046             if (s[1] == 'x') {
7047                 shift = 4;
7048                 s += 2;
7049             } else if (s[1] == 'b') {
7050                 shift = 1;
7051                 s += 2;
7052             }
7053             /* check for a decimal in disguise */
7054             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7055                 goto decimal;
7056             /* so it must be octal */
7057             else {
7058                 shift = 3;
7059                 s++;
7060             }
7061
7062             if (*s == '_') {
7063                if (ckWARN(WARN_SYNTAX))
7064                    Perl_warner(aTHX_ WARN_SYNTAX,
7065                                "Misplaced _ in number");
7066                lastub = s++;
7067             }
7068
7069             base = bases[shift];
7070             Base = Bases[shift];
7071             max  = maxima[shift];
7072
7073             /* read the rest of the number */
7074             for (;;) {
7075                 /* x is used in the overflow test,
7076                    b is the digit we're adding on. */
7077                 UV x, b;
7078
7079                 switch (*s) {
7080
7081                 /* if we don't mention it, we're done */
7082                 default:
7083                     goto out;
7084
7085                 /* _ are ignored -- but warned about if consecutive */
7086                 case '_':
7087                     if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7088                         Perl_warner(aTHX_ WARN_SYNTAX,
7089                                     "Misplaced _ in number");
7090                     lastub = s++;
7091                     break;
7092
7093                 /* 8 and 9 are not octal */
7094                 case '8': case '9':
7095                     if (shift == 3)
7096                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7097                     /* FALL THROUGH */
7098
7099                 /* octal digits */
7100                 case '2': case '3': case '4':
7101                 case '5': case '6': case '7':
7102                     if (shift == 1)
7103                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7104                     /* FALL THROUGH */
7105
7106                 case '0': case '1':
7107                     b = *s++ & 15;              /* ASCII digit -> value of digit */
7108                     goto digit;
7109
7110                 /* hex digits */
7111                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7112                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7113                     /* make sure they said 0x */
7114                     if (shift != 4)
7115                         goto out;
7116                     b = (*s++ & 7) + 9;
7117
7118                     /* Prepare to put the digit we have onto the end
7119                        of the number so far.  We check for overflows.
7120                     */
7121
7122                   digit:
7123                     if (!overflowed) {
7124                         x = u << shift; /* make room for the digit */
7125
7126                         if ((x >> shift) != u
7127                             && !(PL_hints & HINT_NEW_BINARY)) {
7128                             overflowed = TRUE;
7129                             n = (NV) u;
7130                             if (ckWARN_d(WARN_OVERFLOW))
7131                                 Perl_warner(aTHX_ WARN_OVERFLOW,
7132                                             "Integer overflow in %s number",
7133                                             base);
7134                         } else
7135                             u = x | b;          /* add the digit to the end */
7136                     }
7137                     if (overflowed) {
7138                         n *= nvshift[shift];
7139                         /* If an NV has not enough bits in its
7140                          * mantissa to represent an UV this summing of
7141                          * small low-order numbers is a waste of time
7142                          * (because the NV cannot preserve the
7143                          * low-order bits anyway): we could just
7144                          * remember when did we overflow and in the
7145                          * end just multiply n by the right
7146                          * amount. */
7147                         n += (NV) b;
7148                     }
7149                     break;
7150                 }
7151             }
7152
7153           /* if we get here, we had success: make a scalar value from
7154              the number.
7155           */
7156           out:
7157
7158             /* final misplaced underbar check */
7159             if (s[-1] == '_') {
7160                 if (ckWARN(WARN_SYNTAX))
7161                     Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7162             }
7163
7164             sv = NEWSV(92,0);
7165             if (overflowed) {
7166                 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7167                     Perl_warner(aTHX_ WARN_PORTABLE,
7168                                 "%s number > %s non-portable",
7169                                 Base, max);
7170                 sv_setnv(sv, n);
7171             }
7172             else {
7173 #if UVSIZE > 4
7174                 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7175                     Perl_warner(aTHX_ WARN_PORTABLE,
7176                                 "%s number > %s non-portable",
7177                                 Base, max);
7178 #endif
7179                 sv_setuv(sv, u);
7180             }
7181             if (PL_hints & HINT_NEW_BINARY)
7182                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7183         }
7184         break;
7185
7186     /*
7187       handle decimal numbers.
7188       we're also sent here when we read a 0 as the first digit
7189     */
7190     case '1': case '2': case '3': case '4': case '5':
7191     case '6': case '7': case '8': case '9': case '.':
7192       decimal:
7193         d = PL_tokenbuf;
7194         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7195         floatit = FALSE;
7196
7197         /* read next group of digits and _ and copy into d */
7198         while (isDIGIT(*s) || *s == '_') {
7199             /* skip underscores, checking for misplaced ones
7200                if -w is on
7201             */
7202             if (*s == '_') {
7203                 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7204                     Perl_warner(aTHX_ WARN_SYNTAX,
7205                                 "Misplaced _ in number");
7206                 lastub = s++;
7207             }
7208             else {
7209                 /* check for end of fixed-length buffer */
7210                 if (d >= e)
7211                     Perl_croak(aTHX_ number_too_long);
7212                 /* if we're ok, copy the character */
7213                 *d++ = *s++;
7214             }
7215         }
7216
7217         /* final misplaced underbar check */
7218         if (lastub && s == lastub + 1) {
7219             if (ckWARN(WARN_SYNTAX))
7220                 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7221         }
7222
7223         /* read a decimal portion if there is one.  avoid
7224            3..5 being interpreted as the number 3. followed
7225            by .5
7226         */
7227         if (*s == '.' && s[1] != '.') {
7228             floatit = TRUE;
7229             *d++ = *s++;
7230
7231             if (*s == '_') {
7232                 if (ckWARN(WARN_SYNTAX))
7233                     Perl_warner(aTHX_ WARN_SYNTAX,
7234                                 "Misplaced _ in number");
7235                 lastub = s;
7236             }
7237
7238             /* copy, ignoring underbars, until we run out of digits.
7239             */
7240             for (; isDIGIT(*s) || *s == '_'; s++) {
7241                 /* fixed length buffer check */
7242                 if (d >= e)
7243                     Perl_croak(aTHX_ number_too_long);
7244                 if (*s == '_') {
7245                    if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7246                        Perl_warner(aTHX_ WARN_SYNTAX,
7247                                    "Misplaced _ in number");
7248                    lastub = s;
7249                 }
7250                 else
7251                     *d++ = *s;
7252             }
7253             /* fractional part ending in underbar? */
7254             if (s[-1] == '_') {
7255                 if (ckWARN(WARN_SYNTAX))
7256                     Perl_warner(aTHX_ WARN_SYNTAX,
7257                                 "Misplaced _ in number");
7258             }
7259             if (*s == '.' && isDIGIT(s[1])) {
7260                 /* oops, it's really a v-string, but without the "v" */
7261                 s = start;
7262                 goto vstring;
7263             }
7264         }
7265
7266         /* read exponent part, if present */
7267         if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7268             floatit = TRUE;
7269             s++;
7270
7271             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7272             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
7273
7274             /* stray preinitial _ */
7275             if (*s == '_') {
7276                 if (ckWARN(WARN_SYNTAX))
7277                     Perl_warner(aTHX_ WARN_SYNTAX,
7278                                 "Misplaced _ in number");
7279                 lastub = s++;
7280             }
7281
7282             /* allow positive or negative exponent */
7283             if (*s == '+' || *s == '-')
7284                 *d++ = *s++;
7285
7286             /* stray initial _ */
7287             if (*s == '_') {
7288                 if (ckWARN(WARN_SYNTAX))
7289                     Perl_warner(aTHX_ WARN_SYNTAX,
7290                                 "Misplaced _ in number");
7291                 lastub = s++;
7292             }
7293
7294             /* read digits of exponent */
7295             while (isDIGIT(*s) || *s == '_') {
7296                 if (isDIGIT(*s)) {
7297                     if (d >= e)
7298                         Perl_croak(aTHX_ number_too_long);
7299                     *d++ = *s++;
7300                 }
7301                 else {
7302                    if (ckWARN(WARN_SYNTAX) &&
7303                        ((lastub && s == lastub + 1) ||
7304                         (!isDIGIT(s[1]) && s[1] != '_')))
7305                        Perl_warner(aTHX_ WARN_SYNTAX,
7306                                    "Misplaced _ in number");
7307                    lastub = s++;
7308                 }
7309             }
7310         }
7311
7312
7313         /* make an sv from the string */
7314         sv = NEWSV(92,0);
7315
7316         /*
7317            We try to do an integer conversion first if no characters
7318            indicating "float" have been found.
7319          */
7320
7321         if (!floatit) {
7322             UV uv;
7323             int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7324
7325             if (flags == IS_NUMBER_IN_UV) {
7326               if (uv <= IV_MAX)
7327                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7328               else
7329                 sv_setuv(sv, uv);
7330             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7331               if (uv <= (UV) IV_MIN)
7332                 sv_setiv(sv, -(IV)uv);
7333               else
7334                 floatit = TRUE;
7335             } else
7336               floatit = TRUE;
7337         }
7338         if (floatit) {
7339             /* terminate the string */
7340             *d = '\0';
7341             nv = Atof(PL_tokenbuf);
7342             sv_setnv(sv, nv);
7343         }
7344
7345         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7346                        (PL_hints & HINT_NEW_INTEGER) )
7347             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7348                               (floatit ? "float" : "integer"),
7349                               sv, Nullsv, NULL);
7350         break;
7351
7352     /* if it starts with a v, it could be a v-string */
7353     case 'v':
7354 vstring:
7355                 sv = NEWSV(92,5); /* preallocate storage space */
7356                 s = new_vstring(s,sv);
7357         break;
7358     }
7359
7360     /* make the op for the constant and return */
7361
7362     if (sv)
7363         lvalp->opval = newSVOP(OP_CONST, 0, sv);
7364     else
7365         lvalp->opval = Nullop;
7366
7367     return s;
7368 }
7369
7370 STATIC char *
7371 S_scan_formline(pTHX_ register char *s)
7372 {
7373     register char *eol;
7374     register char *t;
7375     SV *stuff = newSVpvn("",0);
7376     bool needargs = FALSE;
7377
7378     while (!needargs) {
7379         if (*s == '.' || *s == /*{*/'}') {
7380             /*SUPPRESS 530*/
7381 #ifdef PERL_STRICT_CR
7382             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7383 #else
7384             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7385 #endif
7386             if (*t == '\n' || t == PL_bufend)
7387                 break;
7388         }
7389         if (PL_in_eval && !PL_rsfp) {
7390             eol = strchr(s,'\n');
7391             if (!eol++)
7392                 eol = PL_bufend;
7393         }
7394         else
7395             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7396         if (*s != '#') {
7397             for (t = s; t < eol; t++) {
7398                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7399                     needargs = FALSE;
7400                     goto enough;        /* ~~ must be first line in formline */
7401                 }
7402                 if (*t == '@' || *t == '^')
7403                     needargs = TRUE;
7404             }
7405             if (eol > s) {
7406                 sv_catpvn(stuff, s, eol-s);
7407 #ifndef PERL_STRICT_CR
7408                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7409                     char *end = SvPVX(stuff) + SvCUR(stuff);
7410                     end[-2] = '\n';
7411                     end[-1] = '\0';
7412                     SvCUR(stuff)--;
7413                 }
7414 #endif
7415             }
7416             else
7417               break;
7418         }
7419         s = eol;
7420         if (PL_rsfp) {
7421             s = filter_gets(PL_linestr, PL_rsfp, 0);
7422             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7423             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7424             PL_last_lop = PL_last_uni = Nullch;
7425             if (!s) {
7426                 s = PL_bufptr;
7427                 yyerror("Format not terminated");
7428                 break;
7429             }
7430         }
7431         incline(s);
7432     }
7433   enough:
7434     if (SvCUR(stuff)) {
7435         PL_expect = XTERM;
7436         if (needargs) {
7437             PL_lex_state = LEX_NORMAL;
7438             PL_nextval[PL_nexttoke].ival = 0;
7439             force_next(',');
7440         }
7441         else
7442             PL_lex_state = LEX_FORMLINE;
7443         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7444         force_next(THING);
7445         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7446         force_next(LSTOP);
7447     }
7448     else {
7449         SvREFCNT_dec(stuff);
7450         PL_lex_formbrack = 0;
7451         PL_bufptr = s;
7452     }
7453     return s;
7454 }
7455
7456 STATIC void
7457 S_set_csh(pTHX)
7458 {
7459 #ifdef CSH
7460     if (!PL_cshlen)
7461         PL_cshlen = strlen(PL_cshname);
7462 #endif
7463 }
7464
7465 I32
7466 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7467 {
7468     I32 oldsavestack_ix = PL_savestack_ix;
7469     CV* outsidecv = PL_compcv;
7470     AV* comppadlist;
7471
7472     if (PL_compcv) {
7473         assert(SvTYPE(PL_compcv) == SVt_PVCV);
7474     }
7475     SAVEI32(PL_subline);
7476     save_item(PL_subname);
7477     SAVEI32(PL_padix);
7478     SAVECOMPPAD();
7479     SAVESPTR(PL_comppad_name);
7480     SAVESPTR(PL_compcv);
7481     SAVEI32(PL_comppad_name_fill);
7482     SAVEI32(PL_min_intro_pending);
7483     SAVEI32(PL_max_intro_pending);
7484     SAVEI32(PL_pad_reset_pending);
7485
7486     PL_compcv = (CV*)NEWSV(1104,0);
7487     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7488     CvFLAGS(PL_compcv) |= flags;
7489
7490     PL_comppad = newAV();
7491     av_push(PL_comppad, Nullsv);
7492     PL_curpad = AvARRAY(PL_comppad);
7493     PL_comppad_name = newAV();
7494     PL_comppad_name_fill = 0;
7495     PL_min_intro_pending = 0;
7496     PL_padix = 0;
7497     PL_subline = CopLINE(PL_curcop);
7498 #ifdef USE_5005THREADS
7499     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7500     PL_curpad[0] = (SV*)newAV();
7501     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
7502 #endif /* USE_5005THREADS */
7503
7504     comppadlist = newAV();
7505     AvREAL_off(comppadlist);
7506     av_store(comppadlist, 0, (SV*)PL_comppad_name);
7507     av_store(comppadlist, 1, (SV*)PL_comppad);
7508
7509     CvPADLIST(PL_compcv) = comppadlist;
7510     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7511 #ifdef USE_5005THREADS
7512     CvOWNER(PL_compcv) = 0;
7513     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7514     MUTEX_INIT(CvMUTEXP(PL_compcv));
7515 #endif /* USE_5005THREADS */
7516
7517     return oldsavestack_ix;
7518 }
7519
7520 #ifdef __SC__
7521 #pragma segment Perl_yylex
7522 #endif
7523 int
7524 Perl_yywarn(pTHX_ char *s)
7525 {
7526     PL_in_eval |= EVAL_WARNONLY;
7527     yyerror(s);
7528     PL_in_eval &= ~EVAL_WARNONLY;
7529     return 0;
7530 }
7531
7532 int
7533 Perl_yyerror(pTHX_ char *s)
7534 {
7535     char *where = NULL;
7536     char *context = NULL;
7537     int contlen = -1;
7538     SV *msg;
7539
7540     if (!yychar || (yychar == ';' && !PL_rsfp))
7541         where = "at EOF";
7542     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7543       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7544         while (isSPACE(*PL_oldoldbufptr))
7545             PL_oldoldbufptr++;
7546         context = PL_oldoldbufptr;
7547         contlen = PL_bufptr - PL_oldoldbufptr;
7548     }
7549     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7550       PL_oldbufptr != PL_bufptr) {
7551         while (isSPACE(*PL_oldbufptr))
7552             PL_oldbufptr++;
7553         context = PL_oldbufptr;
7554         contlen = PL_bufptr - PL_oldbufptr;
7555     }
7556     else if (yychar > 255)
7557         where = "next token ???";
7558 #ifdef USE_PURE_BISON
7559 /*  GNU Bison sets the value -2 */
7560     else if (yychar == -2) {
7561 #else
7562     else if ((yychar & 127) == 127) {
7563 #endif
7564         if (PL_lex_state == LEX_NORMAL ||
7565            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7566             where = "at end of line";
7567         else if (PL_lex_inpat)
7568             where = "within pattern";
7569         else
7570             where = "within string";
7571     }
7572     else {
7573         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7574         if (yychar < 32)
7575             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7576         else if (isPRINT_LC(yychar))
7577             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7578         else
7579             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7580         where = SvPVX(where_sv);
7581     }
7582     msg = sv_2mortal(newSVpv(s, 0));
7583     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7584                    CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7585     if (context)
7586         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7587     else
7588         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7589     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7590         Perl_sv_catpvf(aTHX_ msg,
7591         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7592                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7593         PL_multi_end = 0;
7594     }
7595     if (PL_in_eval & EVAL_WARNONLY)
7596         Perl_warn(aTHX_ "%"SVf, msg);
7597     else
7598         qerror(msg);
7599     if (PL_error_count >= 10) {
7600         if (PL_in_eval && SvCUR(ERRSV))
7601             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7602                        ERRSV, CopFILE(PL_curcop));
7603         else
7604             Perl_croak(aTHX_ "%s has too many errors.\n",
7605                        CopFILE(PL_curcop));
7606     }
7607     PL_in_my = 0;
7608     PL_in_my_stash = Nullhv;
7609     return 0;
7610 }
7611 #ifdef __SC__
7612 #pragma segment Main
7613 #endif
7614
7615 STATIC char*
7616 S_swallow_bom(pTHX_ U8 *s)
7617 {
7618     STRLEN slen;
7619     slen = SvCUR(PL_linestr);
7620     switch (*s) {
7621     case 0xFF:
7622         if (s[1] == 0xFE) {
7623             /* UTF-16 little-endian */
7624             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
7625                 Perl_croak(aTHX_ "Unsupported script encoding");
7626 #ifndef PERL_NO_UTF16_FILTER
7627             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7628             s += 2;
7629             if (PL_bufend > (char*)s) {
7630                 U8 *news;
7631                 I32 newlen;
7632
7633                 filter_add(utf16rev_textfilter, NULL);
7634                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7635                 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7636                                                  PL_bufend - (char*)s - 1,
7637                                                  &newlen);
7638                 Copy(news, s, newlen, U8);
7639                 SvCUR_set(PL_linestr, newlen);
7640                 PL_bufend = SvPVX(PL_linestr) + newlen;
7641                 news[newlen++] = '\0';
7642                 Safefree(news);
7643             }
7644 #else
7645             Perl_croak(aTHX_ "Unsupported script encoding");
7646 #endif
7647         }
7648         break;
7649     case 0xFE:
7650         if (s[1] == 0xFF) {   /* UTF-16 big-endian */
7651 #ifndef PERL_NO_UTF16_FILTER
7652             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7653             s += 2;
7654             if (PL_bufend > (char *)s) {
7655                 U8 *news;
7656                 I32 newlen;
7657
7658                 filter_add(utf16_textfilter, NULL);
7659                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7660                 PL_bufend = (char*)utf16_to_utf8(s, news,
7661                                                  PL_bufend - (char*)s,
7662                                                  &newlen);
7663                 Copy(news, s, newlen, U8);
7664                 SvCUR_set(PL_linestr, newlen);
7665                 PL_bufend = SvPVX(PL_linestr) + newlen;
7666                 news[newlen++] = '\0';
7667                 Safefree(news);
7668             }
7669 #else
7670             Perl_croak(aTHX_ "Unsupported script encoding");
7671 #endif
7672         }
7673         break;
7674     case 0xEF:
7675         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7676             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7677             s += 3;                      /* UTF-8 */
7678         }
7679         break;
7680     case 0:
7681         if (slen > 3 && s[1] == 0 &&  /* UTF-32 big-endian */
7682             s[2] == 0xFE && s[3] == 0xFF)
7683         {
7684             Perl_croak(aTHX_ "Unsupported script encoding");
7685         }
7686     }
7687     return (char*)s;
7688 }
7689
7690 /*
7691  * restore_rsfp
7692  * Restore a source filter.
7693  */
7694
7695 static void
7696 restore_rsfp(pTHX_ void *f)
7697 {
7698     PerlIO *fp = (PerlIO*)f;
7699
7700     if (PL_rsfp == PerlIO_stdin())
7701         PerlIO_clearerr(PL_rsfp);
7702     else if (PL_rsfp && (PL_rsfp != fp))
7703         PerlIO_close(PL_rsfp);
7704     PL_rsfp = fp;
7705 }
7706
7707 #ifndef PERL_NO_UTF16_FILTER
7708 static I32
7709 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7710 {
7711     I32 count = FILTER_READ(idx+1, sv, maxlen);
7712     if (count) {
7713         U8* tmps;
7714         U8* tend;
7715         I32 newlen;
7716         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7717         if (!*SvPV_nolen(sv))
7718         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7719         return count;
7720
7721         tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7722         sv_usepvn(sv, (char*)tmps, tend - tmps);
7723     }
7724     return count;
7725 }
7726
7727 static I32
7728 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7729 {
7730     I32 count = FILTER_READ(idx+1, sv, maxlen);
7731     if (count) {
7732         U8* tmps;
7733         U8* tend;
7734         I32 newlen;
7735         if (!*SvPV_nolen(sv))
7736         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7737         return count;
7738
7739         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7740         tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7741         sv_usepvn(sv, (char*)tmps, tend - tmps);
7742     }
7743     return count;
7744 }
7745 #endif
7746