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