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