toke.c

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