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