toke.c

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