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