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 #ifdef IV_IS_QUAD
3566             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3567                                     Perl_newSVpvf(aTHX_ "%" PERL_PRId64, (IV)PL_curcop->cop_line));
3568 #else
3569             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3570                                     Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3571 #endif
3572             TERM(THING);
3573
3574         case KEY___PACKAGE__:
3575             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3576                                         (PL_curstash
3577                                          ? newSVsv(PL_curstname)
3578                                          : &PL_sv_undef));
3579             TERM(THING);
3580
3581         case KEY___DATA__:
3582         case KEY___END__: {
3583             GV *gv;
3584
3585             /*SUPPRESS 560*/
3586             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3587                 char *pname = "main";
3588                 if (PL_tokenbuf[2] == 'D')
3589                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3590                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3591                 GvMULTI_on(gv);
3592                 if (!GvIO(gv))
3593                     GvIOp(gv) = newIO();
3594                 IoIFP(GvIOp(gv)) = PL_rsfp;
3595 #if defined(HAS_FCNTL) && defined(F_SETFD)
3596                 {
3597                     int fd = PerlIO_fileno(PL_rsfp);
3598                     fcntl(fd,F_SETFD,fd >= 3);
3599                 }
3600 #endif
3601                 /* Mark this internal pseudo-handle as clean */
3602                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3603                 if (PL_preprocess)
3604                     IoTYPE(GvIOp(gv)) = '|';
3605                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3606                     IoTYPE(GvIOp(gv)) = '-';
3607                 else
3608                     IoTYPE(GvIOp(gv)) = '<';
3609                 PL_rsfp = Nullfp;
3610             }
3611             goto fake_eof;
3612         }
3613
3614         case KEY_AUTOLOAD:
3615         case KEY_DESTROY:
3616         case KEY_BEGIN:
3617         case KEY_END:
3618         case KEY_INIT:
3619             if (PL_expect == XSTATE) {
3620                 s = PL_bufptr;
3621                 goto really_sub;
3622             }
3623             goto just_a_word;
3624
3625         case KEY_CORE:
3626             if (*s == ':' && s[1] == ':') {
3627                 s += 2;
3628                 d = s;
3629                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3630                 tmp = keyword(PL_tokenbuf, len);
3631                 if (tmp < 0)
3632                     tmp = -tmp;
3633                 goto reserved_word;
3634             }
3635             goto just_a_word;
3636
3637         case KEY_abs:
3638             UNI(OP_ABS);
3639
3640         case KEY_alarm:
3641             UNI(OP_ALARM);
3642
3643         case KEY_accept:
3644             LOP(OP_ACCEPT,XTERM);
3645
3646         case KEY_and:
3647             OPERATOR(ANDOP);
3648
3649         case KEY_atan2:
3650             LOP(OP_ATAN2,XTERM);
3651
3652         case KEY_bind:
3653             LOP(OP_BIND,XTERM);
3654
3655         case KEY_binmode:
3656             UNI(OP_BINMODE);
3657
3658         case KEY_bless:
3659             LOP(OP_BLESS,XTERM);
3660
3661         case KEY_chop:
3662             UNI(OP_CHOP);
3663
3664         case KEY_continue:
3665             PREBLOCK(CONTINUE);
3666
3667         case KEY_chdir:
3668             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3669             UNI(OP_CHDIR);
3670
3671         case KEY_close:
3672             UNI(OP_CLOSE);
3673
3674         case KEY_closedir:
3675             UNI(OP_CLOSEDIR);
3676
3677         case KEY_cmp:
3678             Eop(OP_SCMP);
3679
3680         case KEY_caller:
3681             UNI(OP_CALLER);
3682
3683         case KEY_crypt:
3684 #ifdef FCRYPT
3685             if (!PL_cryptseen++)
3686                 init_des();
3687 #endif
3688             LOP(OP_CRYPT,XTERM);
3689
3690         case KEY_chmod:
3691             if (ckWARN(WARN_OCTAL)) {
3692                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3693                 if (*d != '0' && isDIGIT(*d))
3694                     yywarn("chmod: mode argument is missing initial 0");
3695             }
3696             LOP(OP_CHMOD,XTERM);
3697
3698         case KEY_chown:
3699             LOP(OP_CHOWN,XTERM);
3700
3701         case KEY_connect:
3702             LOP(OP_CONNECT,XTERM);
3703
3704         case KEY_chr:
3705             UNI(OP_CHR);
3706
3707         case KEY_cos:
3708             UNI(OP_COS);
3709
3710         case KEY_chroot:
3711             UNI(OP_CHROOT);
3712
3713         case KEY_do:
3714             s = skipspace(s);
3715             if (*s == '{')
3716                 PRETERMBLOCK(DO);
3717             if (*s != '\'')
3718                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3719             OPERATOR(DO);
3720
3721         case KEY_die:
3722             PL_hints |= HINT_BLOCK_SCOPE;
3723             LOP(OP_DIE,XTERM);
3724
3725         case KEY_defined:
3726             UNI(OP_DEFINED);
3727
3728         case KEY_delete:
3729             UNI(OP_DELETE);
3730
3731         case KEY_dbmopen:
3732             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3733             LOP(OP_DBMOPEN,XTERM);
3734
3735         case KEY_dbmclose:
3736             UNI(OP_DBMCLOSE);
3737
3738         case KEY_dump:
3739             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3740             LOOPX(OP_DUMP);
3741
3742         case KEY_else:
3743             PREBLOCK(ELSE);
3744
3745         case KEY_elsif:
3746             yylval.ival = PL_curcop->cop_line;
3747             OPERATOR(ELSIF);
3748
3749         case KEY_eq:
3750             Eop(OP_SEQ);
3751
3752         case KEY_exists:
3753             UNI(OP_EXISTS);
3754
3755         case KEY_exit:
3756             UNI(OP_EXIT);
3757
3758         case KEY_eval:
3759             s = skipspace(s);
3760             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3761             UNIBRACK(OP_ENTEREVAL);
3762
3763         case KEY_eof:
3764             UNI(OP_EOF);
3765
3766         case KEY_exp:
3767             UNI(OP_EXP);
3768
3769         case KEY_each:
3770             UNI(OP_EACH);
3771
3772         case KEY_exec:
3773             set_csh();
3774             LOP(OP_EXEC,XREF);
3775
3776         case KEY_endhostent:
3777             FUN0(OP_EHOSTENT);
3778
3779         case KEY_endnetent:
3780             FUN0(OP_ENETENT);
3781
3782         case KEY_endservent:
3783             FUN0(OP_ESERVENT);
3784
3785         case KEY_endprotoent:
3786             FUN0(OP_EPROTOENT);
3787
3788         case KEY_endpwent:
3789             FUN0(OP_EPWENT);
3790
3791         case KEY_endgrent:
3792             FUN0(OP_EGRENT);
3793
3794         case KEY_for:
3795         case KEY_foreach:
3796             yylval.ival = PL_curcop->cop_line;
3797             s = skipspace(s);
3798             if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3799                 char *p = s;
3800                 if ((PL_bufend - p) >= 3 &&
3801                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3802                     p += 2;
3803                 p = skipspace(p);
3804                 if (isIDFIRST_lazy(p))
3805                     Perl_croak(aTHX_ "Missing $ on loop variable");
3806             }
3807             OPERATOR(FOR);
3808
3809         case KEY_formline:
3810             LOP(OP_FORMLINE,XTERM);
3811
3812         case KEY_fork:
3813             FUN0(OP_FORK);
3814
3815         case KEY_fcntl:
3816             LOP(OP_FCNTL,XTERM);
3817
3818         case KEY_fileno:
3819             UNI(OP_FILENO);
3820
3821         case KEY_flock:
3822             LOP(OP_FLOCK,XTERM);
3823
3824         case KEY_gt:
3825             Rop(OP_SGT);
3826
3827         case KEY_ge:
3828             Rop(OP_SGE);
3829
3830         case KEY_grep:
3831             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3832
3833         case KEY_goto:
3834             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3835             LOOPX(OP_GOTO);
3836
3837         case KEY_gmtime:
3838             UNI(OP_GMTIME);
3839
3840         case KEY_getc:
3841             UNI(OP_GETC);
3842
3843         case KEY_getppid:
3844             FUN0(OP_GETPPID);
3845
3846         case KEY_getpgrp:
3847             UNI(OP_GETPGRP);
3848
3849         case KEY_getpriority:
3850             LOP(OP_GETPRIORITY,XTERM);
3851
3852         case KEY_getprotobyname:
3853             UNI(OP_GPBYNAME);
3854
3855         case KEY_getprotobynumber:
3856             LOP(OP_GPBYNUMBER,XTERM);
3857
3858         case KEY_getprotoent:
3859             FUN0(OP_GPROTOENT);
3860
3861         case KEY_getpwent:
3862             FUN0(OP_GPWENT);
3863
3864         case KEY_getpwnam:
3865             UNI(OP_GPWNAM);
3866
3867         case KEY_getpwuid:
3868             UNI(OP_GPWUID);
3869
3870         case KEY_getpeername:
3871             UNI(OP_GETPEERNAME);
3872
3873         case KEY_gethostbyname:
3874             UNI(OP_GHBYNAME);
3875
3876         case KEY_gethostbyaddr:
3877             LOP(OP_GHBYADDR,XTERM);
3878
3879         case KEY_gethostent:
3880             FUN0(OP_GHOSTENT);
3881
3882         case KEY_getnetbyname:
3883             UNI(OP_GNBYNAME);
3884
3885         case KEY_getnetbyaddr:
3886             LOP(OP_GNBYADDR,XTERM);
3887
3888         case KEY_getnetent:
3889             FUN0(OP_GNETENT);
3890
3891         case KEY_getservbyname:
3892             LOP(OP_GSBYNAME,XTERM);
3893
3894         case KEY_getservbyport:
3895             LOP(OP_GSBYPORT,XTERM);
3896
3897         case KEY_getservent:
3898             FUN0(OP_GSERVENT);
3899
3900         case KEY_getsockname:
3901             UNI(OP_GETSOCKNAME);
3902
3903         case KEY_getsockopt:
3904             LOP(OP_GSOCKOPT,XTERM);
3905
3906         case KEY_getgrent:
3907             FUN0(OP_GGRENT);
3908
3909         case KEY_getgrnam:
3910             UNI(OP_GGRNAM);
3911
3912         case KEY_getgrgid:
3913             UNI(OP_GGRGID);
3914
3915         case KEY_getlogin:
3916             FUN0(OP_GETLOGIN);
3917
3918         case KEY_glob:
3919             set_csh();
3920             LOP(OP_GLOB,XTERM);
3921
3922         case KEY_hex:
3923             UNI(OP_HEX);
3924
3925         case KEY_if:
3926             yylval.ival = PL_curcop->cop_line;
3927             OPERATOR(IF);
3928
3929         case KEY_index:
3930             LOP(OP_INDEX,XTERM);
3931
3932         case KEY_int:
3933             UNI(OP_INT);
3934
3935         case KEY_ioctl:
3936             LOP(OP_IOCTL,XTERM);
3937
3938         case KEY_join:
3939             LOP(OP_JOIN,XTERM);
3940
3941         case KEY_keys:
3942             UNI(OP_KEYS);
3943
3944         case KEY_kill:
3945             LOP(OP_KILL,XTERM);
3946
3947         case KEY_last:
3948             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3949             LOOPX(OP_LAST);
3950
3951         case KEY_lc:
3952             UNI(OP_LC);
3953
3954         case KEY_lcfirst:
3955             UNI(OP_LCFIRST);
3956
3957         case KEY_local:
3958             OPERATOR(LOCAL);
3959
3960         case KEY_length:
3961             UNI(OP_LENGTH);
3962
3963         case KEY_lt:
3964             Rop(OP_SLT);
3965
3966         case KEY_le:
3967             Rop(OP_SLE);
3968
3969         case KEY_localtime:
3970             UNI(OP_LOCALTIME);
3971
3972         case KEY_log:
3973             UNI(OP_LOG);
3974
3975         case KEY_link:
3976             LOP(OP_LINK,XTERM);
3977
3978         case KEY_listen:
3979             LOP(OP_LISTEN,XTERM);
3980
3981         case KEY_lock:
3982             UNI(OP_LOCK);
3983
3984         case KEY_lstat:
3985             UNI(OP_LSTAT);
3986
3987         case KEY_m:
3988             s = scan_pat(s,OP_MATCH);
3989             TERM(sublex_start());
3990
3991         case KEY_map:
3992             LOP(OP_MAPSTART, *s == '(' ? XTERM : XREF);
3993
3994         case KEY_mkdir:
3995             LOP(OP_MKDIR,XTERM);
3996
3997         case KEY_msgctl:
3998             LOP(OP_MSGCTL,XTERM);
3999
4000         case KEY_msgget:
4001             LOP(OP_MSGGET,XTERM);
4002
4003         case KEY_msgrcv:
4004             LOP(OP_MSGRCV,XTERM);
4005
4006         case KEY_msgsnd:
4007             LOP(OP_MSGSND,XTERM);
4008
4009         case KEY_my:
4010             PL_in_my = TRUE;
4011             s = skipspace(s);
4012             if (isIDFIRST_lazy(s)) {
4013                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4014                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4015                 if (!PL_in_my_stash) {
4016                     char tmpbuf[1024];
4017                     PL_bufptr = s;
4018                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4019                     yyerror(tmpbuf);
4020                 }
4021             }
4022             OPERATOR(MY);
4023
4024         case KEY_next:
4025             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4026             LOOPX(OP_NEXT);
4027
4028         case KEY_ne:
4029             Eop(OP_SNE);
4030
4031         case KEY_no:
4032             if (PL_expect != XSTATE)
4033                 yyerror("\"no\" not allowed in expression");
4034             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4035             s = force_version(s);
4036             yylval.ival = 0;
4037             OPERATOR(USE);
4038
4039         case KEY_not:
4040             OPERATOR(NOTOP);
4041
4042         case KEY_open:
4043             s = skipspace(s);
4044             if (isIDFIRST_lazy(s)) {
4045                 char *t;
4046                 for (d = s; isALNUM_lazy(d); d++) ;
4047                 t = skipspace(d);
4048                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4049                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4050                            "Precedence problem: open %.*s should be open(%.*s)",
4051                             d-s,s, d-s,s);
4052             }
4053             LOP(OP_OPEN,XTERM);
4054
4055         case KEY_or:
4056             yylval.ival = OP_OR;
4057             OPERATOR(OROP);
4058
4059         case KEY_ord:
4060             UNI(OP_ORD);
4061
4062         case KEY_oct:
4063             UNI(OP_OCT);
4064
4065         case KEY_opendir:
4066             LOP(OP_OPEN_DIR,XTERM);
4067
4068         case KEY_print:
4069             checkcomma(s,PL_tokenbuf,"filehandle");
4070             LOP(OP_PRINT,XREF);
4071
4072         case KEY_printf:
4073             checkcomma(s,PL_tokenbuf,"filehandle");
4074             LOP(OP_PRTF,XREF);
4075
4076         case KEY_prototype:
4077             UNI(OP_PROTOTYPE);
4078
4079         case KEY_push:
4080             LOP(OP_PUSH,XTERM);
4081
4082         case KEY_pop:
4083             UNI(OP_POP);
4084
4085         case KEY_pos:
4086             UNI(OP_POS);
4087
4088         case KEY_pack:
4089             LOP(OP_PACK,XTERM);
4090
4091         case KEY_package:
4092             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4093             OPERATOR(PACKAGE);
4094
4095         case KEY_pipe:
4096             LOP(OP_PIPE_OP,XTERM);
4097
4098         case KEY_q:
4099             s = scan_str(s);
4100             if (!s)
4101                 missingterm((char*)0);
4102             yylval.ival = OP_CONST;
4103             TERM(sublex_start());
4104
4105         case KEY_quotemeta:
4106             UNI(OP_QUOTEMETA);
4107
4108         case KEY_qw:
4109             s = scan_str(s);
4110             if (!s)
4111                 missingterm((char*)0);
4112             force_next(')');
4113             if (SvCUR(PL_lex_stuff)) {
4114                 OP *words = Nullop;
4115                 int warned = 0;
4116                 d = SvPV_force(PL_lex_stuff, len);
4117                 while (len) {
4118                     for (; isSPACE(*d) && len; --len, ++d) ;
4119                     if (len) {
4120                         char *b = d;
4121                         if (!warned && ckWARN(WARN_SYNTAX)) {
4122                             for (; !isSPACE(*d) && len; --len, ++d) {
4123                                 if (*d == ',') {
4124                                     Perl_warner(aTHX_ WARN_SYNTAX,
4125                                         "Possible attempt to separate words with commas");
4126                                     ++warned;
4127                                 }
4128                                 else if (*d == '#') {
4129                                     Perl_warner(aTHX_ WARN_SYNTAX,
4130                                         "Possible attempt to put comments in qw() list");
4131                                     ++warned;
4132                                 }
4133                             }
4134                         }
4135                         else {
4136                             for (; !isSPACE(*d) && len; --len, ++d) ;
4137                         }
4138                         words = append_elem(OP_LIST, words,
4139                                             newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4140                     }
4141                 }
4142                 if (words) {
4143                     PL_nextval[PL_nexttoke].opval = words;
4144                     force_next(THING);
4145                 }
4146             }
4147             if (PL_lex_stuff)
4148                 SvREFCNT_dec(PL_lex_stuff);
4149             PL_lex_stuff = Nullsv;
4150             PL_expect = XTERM;
4151             TOKEN('(');
4152
4153         case KEY_qq:
4154             s = scan_str(s);
4155             if (!s)
4156                 missingterm((char*)0);
4157             yylval.ival = OP_STRINGIFY;
4158             if (SvIVX(PL_lex_stuff) == '\'')
4159                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4160             TERM(sublex_start());
4161
4162         case KEY_qr:
4163             s = scan_pat(s,OP_QR);
4164             TERM(sublex_start());
4165
4166         case KEY_qx:
4167             s = scan_str(s);
4168             if (!s)
4169                 missingterm((char*)0);
4170             yylval.ival = OP_BACKTICK;
4171             set_csh();
4172             TERM(sublex_start());
4173
4174         case KEY_return:
4175             OLDLOP(OP_RETURN);
4176
4177         case KEY_require:
4178             *PL_tokenbuf = '\0';
4179             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4180             if (isIDFIRST_lazy(PL_tokenbuf))
4181                 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4182             else if (*s == '<')
4183                 yyerror("<> should be quotes");
4184             UNI(OP_REQUIRE);
4185
4186         case KEY_reset:
4187             UNI(OP_RESET);
4188
4189         case KEY_redo:
4190             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4191             LOOPX(OP_REDO);
4192
4193         case KEY_rename:
4194             LOP(OP_RENAME,XTERM);
4195
4196         case KEY_rand:
4197             UNI(OP_RAND);
4198
4199         case KEY_rmdir:
4200             UNI(OP_RMDIR);
4201
4202         case KEY_rindex:
4203             LOP(OP_RINDEX,XTERM);
4204
4205         case KEY_read:
4206             LOP(OP_READ,XTERM);
4207
4208         case KEY_readdir:
4209             UNI(OP_READDIR);
4210
4211         case KEY_readline:
4212             set_csh();
4213             UNI(OP_READLINE);
4214
4215         case KEY_readpipe:
4216             set_csh();
4217             UNI(OP_BACKTICK);
4218
4219         case KEY_rewinddir:
4220             UNI(OP_REWINDDIR);
4221
4222         case KEY_recv:
4223             LOP(OP_RECV,XTERM);
4224
4225         case KEY_reverse:
4226             LOP(OP_REVERSE,XTERM);
4227
4228         case KEY_readlink:
4229             UNI(OP_READLINK);
4230
4231         case KEY_ref:
4232             UNI(OP_REF);
4233
4234         case KEY_s:
4235             s = scan_subst(s);
4236             if (yylval.opval)
4237                 TERM(sublex_start());
4238             else
4239                 TOKEN(1);       /* force error */
4240
4241         case KEY_chomp:
4242             UNI(OP_CHOMP);
4243
4244         case KEY_scalar:
4245             UNI(OP_SCALAR);
4246
4247         case KEY_select:
4248             LOP(OP_SELECT,XTERM);
4249
4250         case KEY_seek:
4251             LOP(OP_SEEK,XTERM);
4252
4253         case KEY_semctl:
4254             LOP(OP_SEMCTL,XTERM);
4255
4256         case KEY_semget:
4257             LOP(OP_SEMGET,XTERM);
4258
4259         case KEY_semop:
4260             LOP(OP_SEMOP,XTERM);
4261
4262         case KEY_send:
4263             LOP(OP_SEND,XTERM);
4264
4265         case KEY_setpgrp:
4266             LOP(OP_SETPGRP,XTERM);
4267
4268         case KEY_setpriority:
4269             LOP(OP_SETPRIORITY,XTERM);
4270
4271         case KEY_sethostent:
4272             UNI(OP_SHOSTENT);
4273
4274         case KEY_setnetent:
4275             UNI(OP_SNETENT);
4276
4277         case KEY_setservent:
4278             UNI(OP_SSERVENT);
4279
4280         case KEY_setprotoent:
4281             UNI(OP_SPROTOENT);
4282
4283         case KEY_setpwent:
4284             FUN0(OP_SPWENT);
4285
4286         case KEY_setgrent:
4287             FUN0(OP_SGRENT);
4288
4289         case KEY_seekdir:
4290             LOP(OP_SEEKDIR,XTERM);
4291
4292         case KEY_setsockopt:
4293             LOP(OP_SSOCKOPT,XTERM);
4294
4295         case KEY_shift:
4296             UNI(OP_SHIFT);
4297
4298         case KEY_shmctl:
4299             LOP(OP_SHMCTL,XTERM);
4300
4301         case KEY_shmget:
4302             LOP(OP_SHMGET,XTERM);
4303
4304         case KEY_shmread:
4305             LOP(OP_SHMREAD,XTERM);
4306
4307         case KEY_shmwrite:
4308             LOP(OP_SHMWRITE,XTERM);
4309
4310         case KEY_shutdown:
4311             LOP(OP_SHUTDOWN,XTERM);
4312
4313         case KEY_sin:
4314             UNI(OP_SIN);
4315
4316         case KEY_sleep:
4317             UNI(OP_SLEEP);
4318
4319         case KEY_socket:
4320             LOP(OP_SOCKET,XTERM);
4321
4322         case KEY_socketpair:
4323             LOP(OP_SOCKPAIR,XTERM);
4324
4325         case KEY_sort:
4326             checkcomma(s,PL_tokenbuf,"subroutine name");
4327             s = skipspace(s);
4328             if (*s == ';' || *s == ')')         /* probably a close */
4329                 Perl_croak(aTHX_ "sort is now a reserved word");
4330             PL_expect = XTERM;
4331             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4332             LOP(OP_SORT,XREF);
4333
4334         case KEY_split:
4335             LOP(OP_SPLIT,XTERM);
4336
4337         case KEY_sprintf:
4338             LOP(OP_SPRINTF,XTERM);
4339
4340         case KEY_splice:
4341             LOP(OP_SPLICE,XTERM);
4342
4343         case KEY_sqrt:
4344             UNI(OP_SQRT);
4345
4346         case KEY_srand:
4347             UNI(OP_SRAND);
4348
4349         case KEY_stat:
4350             UNI(OP_STAT);
4351
4352         case KEY_study:
4353             PL_sawstudy++;
4354             UNI(OP_STUDY);
4355
4356         case KEY_substr:
4357             LOP(OP_SUBSTR,XTERM);
4358
4359         case KEY_format:
4360         case KEY_sub:
4361           really_sub:
4362             s = skipspace(s);
4363
4364             if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4365                 char tmpbuf[sizeof PL_tokenbuf];
4366                 PL_expect = XBLOCK;
4367                 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4368                 if (strchr(tmpbuf, ':'))
4369                     sv_setpv(PL_subname, tmpbuf);
4370                 else {
4371                     sv_setsv(PL_subname,PL_curstname);
4372                     sv_catpvn(PL_subname,"::",2);
4373                     sv_catpvn(PL_subname,tmpbuf,len);
4374                 }
4375                 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4376                 s = skipspace(s);
4377             }
4378             else {
4379                 PL_expect = XTERMBLOCK;
4380                 sv_setpv(PL_subname,"?");
4381             }
4382
4383             if (tmp == KEY_format) {
4384                 s = skipspace(s);
4385                 if (*s == '=')
4386                     PL_lex_formbrack = PL_lex_brackets + 1;
4387                 OPERATOR(FORMAT);
4388             }
4389
4390             /* Look for a prototype */
4391             if (*s == '(') {
4392                 char *p;
4393
4394                 s = scan_str(s);
4395                 if (!s) {
4396                     if (PL_lex_stuff)
4397                         SvREFCNT_dec(PL_lex_stuff);
4398                     PL_lex_stuff = Nullsv;
4399                     Perl_croak(aTHX_ "Prototype not terminated");
4400                 }
4401                 /* strip spaces */
4402                 d = SvPVX(PL_lex_stuff);
4403                 tmp = 0;
4404                 for (p = d; *p; ++p) {
4405                     if (!isSPACE(*p))
4406                         d[tmp++] = *p;
4407                 }
4408                 d[tmp] = '\0';
4409                 SvCUR(PL_lex_stuff) = tmp;
4410
4411                 PL_nexttoke++;
4412                 PL_nextval[1] = PL_nextval[0];
4413                 PL_nexttype[1] = PL_nexttype[0];
4414                 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4415                 PL_nexttype[0] = THING;
4416                 if (PL_nexttoke == 1) {
4417                     PL_lex_defer = PL_lex_state;
4418                     PL_lex_expect = PL_expect;
4419                     PL_lex_state = LEX_KNOWNEXT;
4420                 }
4421                 PL_lex_stuff = Nullsv;
4422             }
4423
4424             if (*SvPV(PL_subname,n_a) == '?') {
4425                 sv_setpv(PL_subname,"__ANON__");
4426                 TOKEN(ANONSUB);
4427             }
4428             PREBLOCK(SUB);
4429
4430         case KEY_system:
4431             set_csh();
4432             LOP(OP_SYSTEM,XREF);
4433
4434         case KEY_symlink:
4435             LOP(OP_SYMLINK,XTERM);
4436
4437         case KEY_syscall:
4438             LOP(OP_SYSCALL,XTERM);
4439
4440         case KEY_sysopen:
4441             LOP(OP_SYSOPEN,XTERM);
4442
4443         case KEY_sysseek:
4444             LOP(OP_SYSSEEK,XTERM);
4445
4446         case KEY_sysread:
4447             LOP(OP_SYSREAD,XTERM);
4448
4449         case KEY_syswrite:
4450             LOP(OP_SYSWRITE,XTERM);
4451
4452         case KEY_tr:
4453             s = scan_trans(s);
4454             TERM(sublex_start());
4455
4456         case KEY_tell:
4457             UNI(OP_TELL);
4458
4459         case KEY_telldir:
4460             UNI(OP_TELLDIR);
4461
4462         case KEY_tie:
4463             LOP(OP_TIE,XTERM);
4464
4465         case KEY_tied:
4466             UNI(OP_TIED);
4467
4468         case KEY_time:
4469             FUN0(OP_TIME);
4470
4471         case KEY_times:
4472             FUN0(OP_TMS);
4473
4474         case KEY_truncate:
4475             LOP(OP_TRUNCATE,XTERM);
4476
4477         case KEY_uc:
4478             UNI(OP_UC);
4479
4480         case KEY_ucfirst:
4481             UNI(OP_UCFIRST);
4482
4483         case KEY_untie:
4484             UNI(OP_UNTIE);
4485
4486         case KEY_until:
4487             yylval.ival = PL_curcop->cop_line;
4488             OPERATOR(UNTIL);
4489
4490         case KEY_unless:
4491             yylval.ival = PL_curcop->cop_line;
4492             OPERATOR(UNLESS);
4493
4494         case KEY_unlink:
4495             LOP(OP_UNLINK,XTERM);
4496
4497         case KEY_undef:
4498             UNI(OP_UNDEF);
4499
4500         case KEY_unpack:
4501             LOP(OP_UNPACK,XTERM);
4502
4503         case KEY_utime:
4504             LOP(OP_UTIME,XTERM);
4505
4506         case KEY_umask:
4507             if (ckWARN(WARN_OCTAL)) {
4508                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4509                 if (*d != '0' && isDIGIT(*d))
4510                     yywarn("umask: argument is missing initial 0");
4511             }
4512             UNI(OP_UMASK);
4513
4514         case KEY_unshift:
4515             LOP(OP_UNSHIFT,XTERM);
4516
4517         case KEY_use:
4518             if (PL_expect != XSTATE)
4519                 yyerror("\"use\" not allowed in expression");
4520             s = skipspace(s);
4521             if(isDIGIT(*s)) {
4522                 s = force_version(s);
4523                 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4524                     PL_nextval[PL_nexttoke].opval = Nullop;
4525                     force_next(WORD);
4526                 }
4527             }
4528             else {
4529                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4530                 s = force_version(s);
4531             }
4532             yylval.ival = 1;
4533             OPERATOR(USE);
4534
4535         case KEY_values:
4536             UNI(OP_VALUES);
4537
4538         case KEY_vec:
4539             PL_sawvec = TRUE;
4540             LOP(OP_VEC,XTERM);
4541
4542         case KEY_while:
4543             yylval.ival = PL_curcop->cop_line;
4544             OPERATOR(WHILE);
4545
4546         case KEY_warn:
4547             PL_hints |= HINT_BLOCK_SCOPE;
4548             LOP(OP_WARN,XTERM);
4549
4550         case KEY_wait:
4551             FUN0(OP_WAIT);
4552
4553         case KEY_waitpid:
4554             LOP(OP_WAITPID,XTERM);
4555
4556         case KEY_wantarray:
4557             FUN0(OP_WANTARRAY);
4558
4559         case KEY_write:
4560 #ifdef EBCDIC
4561         {
4562             static char ctl_l[2];
4563
4564             if (ctl_l[0] == '\0')
4565                 ctl_l[0] = toCTRL('L');
4566             gv_fetchpv(ctl_l,TRUE, SVt_PV);
4567         }
4568 #else
4569             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4570 #endif
4571             UNI(OP_ENTERWRITE);
4572
4573         case KEY_x:
4574             if (PL_expect == XOPERATOR)
4575                 Mop(OP_REPEAT);
4576             check_uni();
4577             goto just_a_word;
4578
4579         case KEY_xor:
4580             yylval.ival = OP_XOR;
4581             OPERATOR(OROP);
4582
4583         case KEY_y:
4584             s = scan_trans(s);
4585             TERM(sublex_start());
4586         }
4587     }}
4588 }
4589
4590 I32
4591 Perl_keyword(pTHX_ register char *d, I32 len)
4592 {
4593     switch (*d) {
4594     case '_':
4595         if (d[1] == '_') {
4596             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4597             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4598             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4599             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4600             if (strEQ(d,"__END__"))             return KEY___END__;
4601         }
4602         break;
4603     case 'A':
4604         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4605         break;
4606     case 'a':
4607         switch (len) {
4608         case 3:
4609             if (strEQ(d,"and"))                 return -KEY_and;
4610             if (strEQ(d,"abs"))                 return -KEY_abs;
4611             break;
4612         case 5:
4613             if (strEQ(d,"alarm"))               return -KEY_alarm;
4614             if (strEQ(d,"atan2"))               return -KEY_atan2;
4615             break;
4616         case 6:
4617             if (strEQ(d,"accept"))              return -KEY_accept;
4618             break;
4619         }
4620         break;
4621     case 'B':
4622         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4623         break;
4624     case 'b':
4625         if (strEQ(d,"bless"))                   return -KEY_bless;
4626         if (strEQ(d,"bind"))                    return -KEY_bind;
4627         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4628         break;
4629     case 'C':
4630         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4631         break;
4632     case 'c':
4633         switch (len) {
4634         case 3:
4635             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4636             if (strEQ(d,"chr"))                 return -KEY_chr;
4637             if (strEQ(d,"cos"))                 return -KEY_cos;
4638             break;
4639         case 4:
4640             if (strEQ(d,"chop"))                return KEY_chop;
4641             break;
4642         case 5:
4643             if (strEQ(d,"close"))               return -KEY_close;
4644             if (strEQ(d,"chdir"))               return -KEY_chdir;
4645             if (strEQ(d,"chomp"))               return KEY_chomp;
4646             if (strEQ(d,"chmod"))               return -KEY_chmod;
4647             if (strEQ(d,"chown"))               return -KEY_chown;
4648             if (strEQ(d,"crypt"))               return -KEY_crypt;
4649             break;
4650         case 6:
4651             if (strEQ(d,"chroot"))              return -KEY_chroot;
4652             if (strEQ(d,"caller"))              return -KEY_caller;
4653             break;
4654         case 7:
4655             if (strEQ(d,"connect"))             return -KEY_connect;
4656             break;
4657         case 8:
4658             if (strEQ(d,"closedir"))            return -KEY_closedir;
4659             if (strEQ(d,"continue"))            return -KEY_continue;
4660             break;
4661         }
4662         break;
4663     case 'D':
4664         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4665         break;
4666     case 'd':
4667         switch (len) {
4668         case 2:
4669             if (strEQ(d,"do"))                  return KEY_do;
4670             break;
4671         case 3:
4672             if (strEQ(d,"die"))                 return -KEY_die;
4673             break;
4674         case 4:
4675             if (strEQ(d,"dump"))                return -KEY_dump;
4676             break;
4677         case 6:
4678             if (strEQ(d,"delete"))              return KEY_delete;
4679             break;
4680         case 7:
4681             if (strEQ(d,"defined"))             return KEY_defined;
4682             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
4683             break;
4684         case 8:
4685             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
4686             break;
4687         }
4688         break;
4689     case 'E':
4690         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
4691         if (strEQ(d,"END"))                     return KEY_END;
4692         break;
4693     case 'e':
4694         switch (len) {
4695         case 2:
4696             if (strEQ(d,"eq"))                  return -KEY_eq;
4697             break;
4698         case 3:
4699             if (strEQ(d,"eof"))                 return -KEY_eof;
4700             if (strEQ(d,"exp"))                 return -KEY_exp;
4701             break;
4702         case 4:
4703             if (strEQ(d,"else"))                return KEY_else;
4704             if (strEQ(d,"exit"))                return -KEY_exit;
4705             if (strEQ(d,"eval"))                return KEY_eval;
4706             if (strEQ(d,"exec"))                return -KEY_exec;
4707             if (strEQ(d,"each"))                return KEY_each;
4708             break;
4709         case 5:
4710             if (strEQ(d,"elsif"))               return KEY_elsif;
4711             break;
4712         case 6:
4713             if (strEQ(d,"exists"))              return KEY_exists;
4714             if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4715             break;
4716         case 8:
4717             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
4718             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
4719             break;
4720         case 9:
4721             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
4722             break;
4723         case 10:
4724             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
4725             if (strEQ(d,"endservent"))          return -KEY_endservent;
4726             break;
4727         case 11:
4728             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
4729             break;
4730         }
4731         break;
4732     case 'f':
4733         switch (len) {
4734         case 3:
4735             if (strEQ(d,"for"))                 return KEY_for;
4736             break;
4737         case 4:
4738             if (strEQ(d,"fork"))                return -KEY_fork;
4739             break;
4740         case 5:
4741             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
4742             if (strEQ(d,"flock"))               return -KEY_flock;
4743             break;
4744         case 6:
4745             if (strEQ(d,"format"))              return KEY_format;
4746             if (strEQ(d,"fileno"))              return -KEY_fileno;
4747             break;
4748         case 7:
4749             if (strEQ(d,"foreach"))             return KEY_foreach;
4750             break;
4751         case 8:
4752             if (strEQ(d,"formline"))            return -KEY_formline;
4753             break;
4754         }
4755         break;
4756     case 'G':
4757         if (len == 2) {
4758             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
4759             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
4760         }
4761         break;
4762     case 'g':
4763         if (strnEQ(d,"get",3)) {
4764             d += 3;
4765             if (*d == 'p') {
4766                 switch (len) {
4767                 case 7:
4768                     if (strEQ(d,"ppid"))        return -KEY_getppid;
4769                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
4770                     break;
4771                 case 8:
4772                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
4773                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
4774                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
4775                     break;
4776                 case 11:
4777                     if (strEQ(d,"peername"))    return -KEY_getpeername;
4778                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
4779                     if (strEQ(d,"priority"))    return -KEY_getpriority;
4780                     break;
4781                 case 14:
4782                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4783                     break;
4784                 case 16:
4785                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4786                     break;
4787                 }
4788             }
4789             else if (*d == 'h') {
4790                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
4791                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
4792                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
4793             }
4794             else if (*d == 'n') {
4795                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
4796                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
4797                 if (strEQ(d,"netent"))          return -KEY_getnetent;
4798             }
4799             else if (*d == 's') {
4800                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
4801                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
4802                 if (strEQ(d,"servent"))         return -KEY_getservent;
4803                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
4804                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
4805             }
4806             else if (*d == 'g') {
4807                 if (strEQ(d,"grent"))           return -KEY_getgrent;
4808                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
4809                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
4810             }
4811             else if (*d == 'l') {
4812                 if (strEQ(d,"login"))           return -KEY_getlogin;
4813             }
4814             else if (strEQ(d,"c"))              return -KEY_getc;
4815             break;
4816         }
4817         switch (len) {
4818         case 2:
4819             if (strEQ(d,"gt"))                  return -KEY_gt;
4820             if (strEQ(d,"ge"))                  return -KEY_ge;
4821             break;
4822         case 4:
4823             if (strEQ(d,"grep"))                return KEY_grep;
4824             if (strEQ(d,"goto"))                return KEY_goto;
4825             if (strEQ(d,"glob"))                return KEY_glob;
4826             break;
4827         case 6:
4828             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
4829             break;
4830         }
4831         break;
4832     case 'h':
4833         if (strEQ(d,"hex"))                     return -KEY_hex;
4834         break;
4835     case 'I':
4836         if (strEQ(d,"INIT"))                    return KEY_INIT;
4837         break;
4838     case 'i':
4839         switch (len) {
4840         case 2:
4841             if (strEQ(d,"if"))                  return KEY_if;
4842             break;
4843         case 3:
4844             if (strEQ(d,"int"))                 return -KEY_int;
4845             break;
4846         case 5:
4847             if (strEQ(d,"index"))               return -KEY_index;
4848             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
4849             break;
4850         }
4851         break;
4852     case 'j':
4853         if (strEQ(d,"join"))                    return -KEY_join;
4854         break;
4855     case 'k':
4856         if (len == 4) {
4857             if (strEQ(d,"keys"))                return KEY_keys;
4858             if (strEQ(d,"kill"))                return -KEY_kill;
4859         }
4860         break;
4861     case 'L':
4862         if (len == 2) {
4863             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
4864             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
4865         }
4866         break;
4867     case 'l':
4868         switch (len) {
4869         case 2:
4870             if (strEQ(d,"lt"))                  return -KEY_lt;
4871             if (strEQ(d,"le"))                  return -KEY_le;
4872             if (strEQ(d,"lc"))                  return -KEY_lc;
4873             break;
4874         case 3:
4875             if (strEQ(d,"log"))                 return -KEY_log;
4876             break;
4877         case 4:
4878             if (strEQ(d,"last"))                return KEY_last;
4879             if (strEQ(d,"link"))                return -KEY_link;
4880             if (strEQ(d,"lock"))                return -KEY_lock;
4881             break;
4882         case 5:
4883             if (strEQ(d,"local"))               return KEY_local;
4884             if (strEQ(d,"lstat"))               return -KEY_lstat;
4885             break;
4886         case 6:
4887             if (strEQ(d,"length"))              return -KEY_length;
4888             if (strEQ(d,"listen"))              return -KEY_listen;
4889             break;
4890         case 7:
4891             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
4892             break;
4893         case 9:
4894             if (strEQ(d,"localtime"))           return -KEY_localtime;
4895             break;
4896         }
4897         break;
4898     case 'm':
4899         switch (len) {
4900         case 1:                                 return KEY_m;
4901         case 2:
4902             if (strEQ(d,"my"))                  return KEY_my;
4903             break;
4904         case 3:
4905             if (strEQ(d,"map"))                 return KEY_map;
4906             break;
4907         case 5:
4908             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
4909             break;
4910         case 6:
4911             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
4912             if (strEQ(d,"msgget"))              return -KEY_msgget;
4913             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
4914             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
4915             break;
4916         }
4917         break;
4918     case 'N':
4919         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
4920         break;
4921     case 'n':
4922         if (strEQ(d,"next"))                    return KEY_next;
4923         if (strEQ(d,"ne"))                      return -KEY_ne;
4924         if (strEQ(d,"not"))                     return -KEY_not;
4925         if (strEQ(d,"no"))                      return KEY_no;
4926         break;
4927     case 'o':
4928         switch (len) {
4929         case 2:
4930             if (strEQ(d,"or"))                  return -KEY_or;
4931             break;
4932         case 3:
4933             if (strEQ(d,"ord"))                 return -KEY_ord;
4934             if (strEQ(d,"oct"))                 return -KEY_oct;
4935             if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4936                                                 return 0;}
4937             break;
4938         case 4:
4939             if (strEQ(d,"open"))                return -KEY_open;
4940             break;
4941         case 7:
4942             if (strEQ(d,"opendir"))             return -KEY_opendir;
4943             break;
4944         }
4945         break;
4946     case 'p':
4947         switch (len) {
4948         case 3:
4949             if (strEQ(d,"pop"))                 return KEY_pop;
4950             if (strEQ(d,"pos"))                 return KEY_pos;
4951             break;
4952         case 4:
4953             if (strEQ(d,"push"))                return KEY_push;
4954             if (strEQ(d,"pack"))                return -KEY_pack;
4955             if (strEQ(d,"pipe"))                return -KEY_pipe;
4956             break;
4957         case 5:
4958             if (strEQ(d,"print"))               return KEY_print;
4959             break;
4960         case 6:
4961             if (strEQ(d,"printf"))              return KEY_printf;
4962             break;
4963         case 7:
4964             if (strEQ(d,"package"))             return KEY_package;
4965             break;
4966         case 9:
4967             if (strEQ(d,"prototype"))           return KEY_prototype;
4968         }
4969         break;
4970     case 'q':
4971         if (len <= 2) {
4972             if (strEQ(d,"q"))                   return KEY_q;
4973             if (strEQ(d,"qr"))                  return KEY_qr;
4974             if (strEQ(d,"qq"))                  return KEY_qq;
4975             if (strEQ(d,"qw"))                  return KEY_qw;
4976             if (strEQ(d,"qx"))                  return KEY_qx;
4977         }
4978         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
4979         break;
4980     case 'r':
4981         switch (len) {
4982         case 3:
4983             if (strEQ(d,"ref"))                 return -KEY_ref;
4984             break;
4985         case 4:
4986             if (strEQ(d,"read"))                return -KEY_read;
4987             if (strEQ(d,"rand"))                return -KEY_rand;
4988             if (strEQ(d,"recv"))                return -KEY_recv;
4989             if (strEQ(d,"redo"))                return KEY_redo;
4990             break;
4991         case 5:
4992             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
4993             if (strEQ(d,"reset"))               return -KEY_reset;
4994             break;
4995         case 6:
4996             if (strEQ(d,"return"))              return KEY_return;
4997             if (strEQ(d,"rename"))              return -KEY_rename;
4998             if (strEQ(d,"rindex"))              return -KEY_rindex;
4999             break;
5000         case 7:
5001             if (strEQ(d,"require"))             return -KEY_require;
5002             if (strEQ(d,"reverse"))             return -KEY_reverse;
5003             if (strEQ(d,"readdir"))             return -KEY_readdir;
5004             break;
5005         case 8:
5006             if (strEQ(d,"readlink"))            return -KEY_readlink;
5007             if (strEQ(d,"readline"))            return -KEY_readline;
5008             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5009             break;
5010         case 9:
5011             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5012             break;
5013         }
5014         break;
5015     case 's':
5016         switch (d[1]) {
5017         case 0:                                 return KEY_s;
5018         case 'c':
5019             if (strEQ(d,"scalar"))              return KEY_scalar;
5020             break;
5021         case 'e':
5022             switch (len) {
5023             case 4:
5024                 if (strEQ(d,"seek"))            return -KEY_seek;
5025                 if (strEQ(d,"send"))            return -KEY_send;
5026                 break;
5027             case 5:
5028                 if (strEQ(d,"semop"))           return -KEY_semop;
5029                 break;
5030             case 6:
5031                 if (strEQ(d,"select"))          return -KEY_select;
5032                 if (strEQ(d,"semctl"))          return -KEY_semctl;
5033                 if (strEQ(d,"semget"))          return -KEY_semget;
5034                 break;
5035             case 7:
5036                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
5037                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
5038                 break;
5039             case 8:
5040                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
5041                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
5042                 break;
5043             case 9:
5044                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
5045                 break;
5046             case 10:
5047                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
5048                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
5049                 if (strEQ(d,"setservent"))      return -KEY_setservent;
5050                 break;
5051             case 11:
5052                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
5053                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
5054                 break;
5055             }
5056             break;
5057         case 'h':
5058             switch (len) {
5059             case 5:
5060                 if (strEQ(d,"shift"))           return KEY_shift;
5061                 break;
5062             case 6:
5063                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
5064                 if (strEQ(d,"shmget"))          return -KEY_shmget;
5065                 break;
5066             case 7:
5067                 if (strEQ(d,"shmread"))         return -KEY_shmread;
5068                 break;
5069             case 8:
5070                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
5071                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
5072                 break;
5073             }
5074             break;
5075         case 'i':
5076             if (strEQ(d,"sin"))                 return -KEY_sin;
5077             break;
5078         case 'l':
5079             if (strEQ(d,"sleep"))               return -KEY_sleep;
5080             break;
5081         case 'o':
5082             if (strEQ(d,"sort"))                return KEY_sort;
5083             if (strEQ(d,"socket"))              return -KEY_socket;
5084             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
5085             break;
5086         case 'p':
5087             if (strEQ(d,"split"))               return KEY_split;
5088             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
5089             if (strEQ(d,"splice"))              return KEY_splice;
5090             break;
5091         case 'q':
5092             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
5093             break;
5094         case 'r':
5095             if (strEQ(d,"srand"))               return -KEY_srand;
5096             break;
5097         case 't':
5098             if (strEQ(d,"stat"))                return -KEY_stat;
5099             if (strEQ(d,"study"))               return KEY_study;
5100             break;
5101         case 'u':
5102             if (strEQ(d,"substr"))              return -KEY_substr;
5103             if (strEQ(d,"sub"))                 return KEY_sub;
5104             break;
5105         case 'y':
5106             switch (len) {
5107             case 6:
5108                 if (strEQ(d,"system"))          return -KEY_system;
5109                 break;
5110             case 7:
5111                 if (strEQ(d,"symlink"))         return -KEY_symlink;
5112                 if (strEQ(d,"syscall"))         return -KEY_syscall;
5113                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
5114                 if (strEQ(d,"sysread"))         return -KEY_sysread;
5115                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
5116                 break;
5117             case 8:
5118                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
5119                 break;
5120             }
5121             break;
5122         }
5123         break;
5124     case 't':
5125         switch (len) {
5126         case 2:
5127             if (strEQ(d,"tr"))                  return KEY_tr;
5128             break;
5129         case 3:
5130             if (strEQ(d,"tie"))                 return KEY_tie;
5131             break;
5132         case 4:
5133             if (strEQ(d,"tell"))                return -KEY_tell;
5134             if (strEQ(d,"tied"))                return KEY_tied;
5135             if (strEQ(d,"time"))                return -KEY_time;
5136             break;
5137         case 5:
5138             if (strEQ(d,"times"))               return -KEY_times;
5139             break;
5140         case 7:
5141             if (strEQ(d,"telldir"))             return -KEY_telldir;
5142             break;
5143         case 8:
5144             if (strEQ(d,"truncate"))            return -KEY_truncate;
5145             break;
5146         }
5147         break;
5148     case 'u':
5149         switch (len) {
5150         case 2:
5151             if (strEQ(d,"uc"))                  return -KEY_uc;
5152             break;
5153         case 3:
5154             if (strEQ(d,"use"))                 return KEY_use;
5155             break;
5156         case 5:
5157             if (strEQ(d,"undef"))               return KEY_undef;
5158             if (strEQ(d,"until"))               return KEY_until;
5159             if (strEQ(d,"untie"))               return KEY_untie;
5160             if (strEQ(d,"utime"))               return -KEY_utime;
5161             if (strEQ(d,"umask"))               return -KEY_umask;
5162             break;
5163         case 6:
5164             if (strEQ(d,"unless"))              return KEY_unless;
5165             if (strEQ(d,"unpack"))              return -KEY_unpack;
5166             if (strEQ(d,"unlink"))              return -KEY_unlink;
5167             break;
5168         case 7:
5169             if (strEQ(d,"unshift"))             return KEY_unshift;
5170             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
5171             break;
5172         }
5173         break;
5174     case 'v':
5175         if (strEQ(d,"values"))                  return -KEY_values;
5176         if (strEQ(d,"vec"))                     return -KEY_vec;
5177         break;
5178     case 'w':
5179         switch (len) {
5180         case 4:
5181             if (strEQ(d,"warn"))                return -KEY_warn;
5182             if (strEQ(d,"wait"))                return -KEY_wait;
5183             break;
5184         case 5:
5185             if (strEQ(d,"while"))               return KEY_while;
5186             if (strEQ(d,"write"))               return -KEY_write;
5187             break;
5188         case 7:
5189             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
5190             break;
5191         case 9:
5192             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
5193             break;
5194         }
5195         break;
5196     case 'x':
5197         if (len == 1)                           return -KEY_x;
5198         if (strEQ(d,"xor"))                     return -KEY_xor;
5199         break;
5200     case 'y':
5201         if (len == 1)                           return KEY_y;
5202         break;
5203     case 'z':
5204         break;
5205     }
5206     return 0;
5207 }
5208
5209 STATIC void
5210 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5211 {
5212     char *w;
5213
5214     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
5215         dTHR;                           /* only for ckWARN */
5216         if (ckWARN(WARN_SYNTAX)) {
5217             int level = 1;
5218             for (w = s+2; *w && level; w++) {
5219                 if (*w == '(')
5220                     ++level;
5221                 else if (*w == ')')
5222                     --level;
5223             }
5224             if (*w)
5225                 for (; *w && isSPACE(*w); w++) ;
5226             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
5227                 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
5228         }
5229     }
5230     while (s < PL_bufend && isSPACE(*s))
5231         s++;
5232     if (*s == '(')
5233         s++;
5234     while (s < PL_bufend && isSPACE(*s))
5235         s++;
5236     if (isIDFIRST_lazy(s)) {
5237         w = s++;
5238         while (isALNUM_lazy(s))
5239             s++;
5240         while (s < PL_bufend && isSPACE(*s))
5241             s++;
5242         if (*s == ',') {
5243             int kw;
5244             *s = '\0';
5245             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5246             *s = ',';
5247             if (kw)
5248                 return;
5249             Perl_croak(aTHX_ "No comma allowed after %s", what);
5250         }
5251     }
5252 }
5253
5254 STATIC SV *
5255 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
5256 {
5257     dSP;
5258     HV *table = GvHV(PL_hintgv);                 /* ^H */
5259     BINOP myop;
5260     SV *res;
5261     bool oldcatch = CATCH_GET;
5262     SV **cvp;
5263     SV *cv, *typesv;
5264
5265     if (!table) {
5266         yyerror("%^H is not defined");
5267         return sv;
5268     }
5269     cvp = hv_fetch(table, key, strlen(key), FALSE);
5270     if (!cvp || !SvOK(*cvp)) {
5271         char buf[128];
5272         sprintf(buf,"$^H{%s} is not defined", key);
5273         yyerror(buf);
5274         return sv;
5275     }
5276     sv_2mortal(sv);                     /* Parent created it permanently */
5277     cv = *cvp;
5278     if (!pv)
5279         pv = sv_2mortal(newSVpvn(s, len));
5280     if (type)
5281         typesv = sv_2mortal(newSVpv(type, 0));
5282     else
5283         typesv = &PL_sv_undef;
5284     CATCH_SET(TRUE);
5285     Zero(&myop, 1, BINOP);
5286     myop.op_last = (OP *) &myop;
5287     myop.op_next = Nullop;
5288     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
5289
5290     PUSHSTACKi(PERLSI_OVERLOAD);
5291     ENTER;
5292     SAVEOP();
5293     PL_op = (OP *) &myop;
5294     if (PERLDB_SUB && PL_curstash != PL_debstash)
5295         PL_op->op_private |= OPpENTERSUB_DB;
5296     PUTBACK;
5297     Perl_pp_pushmark(aTHX);
5298
5299     EXTEND(sp, 4);
5300     PUSHs(pv);
5301     PUSHs(sv);
5302     PUSHs(typesv);
5303     PUSHs(cv);
5304     PUTBACK;
5305
5306     if (PL_op = Perl_pp_entersub(aTHX))
5307       CALLRUNOPS(aTHX);
5308     LEAVE;
5309     SPAGAIN;
5310
5311     res = POPs;
5312     PUTBACK;
5313     CATCH_SET(oldcatch);
5314     POPSTACK;
5315
5316     if (!SvOK(res)) {
5317         char buf[128];
5318         sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5319         yyerror(buf);
5320     }
5321     return SvREFCNT_inc(res);
5322 }
5323
5324 STATIC char *
5325 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5326 {
5327     register char *d = dest;
5328     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
5329     for (;;) {
5330         if (d >= e)
5331             Perl_croak(aTHX_ ident_too_long);
5332         if (isALNUM(*s))        /* UTF handled below */
5333             *d++ = *s++;
5334         else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5335             *d++ = ':';
5336             *d++ = ':';
5337             s++;
5338         }
5339         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5340             *d++ = *s++;
5341             *d++ = *s++;
5342         }
5343         else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5344             char *t = s + UTF8SKIP(s);
5345             while (*t & 0x80 && is_utf8_mark((U8*)t))
5346                 t += UTF8SKIP(t);
5347             if (d + (t - s) > e)
5348                 Perl_croak(aTHX_ ident_too_long);
5349             Copy(s, d, t - s, char);
5350             d += t - s;
5351             s = t;
5352         }
5353         else {
5354             *d = '\0';
5355             *slp = d - dest;
5356             return s;
5357         }
5358     }
5359 }
5360
5361 STATIC char *
5362 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5363 {
5364     register char *d;
5365     register char *e;
5366     char *bracket = 0;
5367     char funny = *s++;
5368
5369     if (PL_lex_brackets == 0)
5370         PL_lex_fakebrack = 0;
5371     if (isSPACE(*s))
5372         s = skipspace(s);
5373     d = dest;
5374     e = d + destlen - 3;        /* two-character token, ending NUL */
5375     if (isDIGIT(*s)) {
5376         while (isDIGIT(*s)) {
5377             if (d >= e)
5378                 Perl_croak(aTHX_ ident_too_long);
5379             *d++ = *s++;
5380         }
5381     }
5382     else {
5383         for (;;) {
5384             if (d >= e)
5385                 Perl_croak(aTHX_ ident_too_long);
5386             if (isALNUM(*s))    /* UTF handled below */
5387                 *d++ = *s++;
5388             else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5389                 *d++ = ':';
5390                 *d++ = ':';
5391                 s++;
5392             }
5393             else if (*s == ':' && s[1] == ':') {
5394                 *d++ = *s++;
5395                 *d++ = *s++;
5396             }
5397             else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5398                 char *t = s + UTF8SKIP(s);
5399                 while (*t & 0x80 && is_utf8_mark((U8*)t))
5400                     t += UTF8SKIP(t);
5401                 if (d + (t - s) > e)
5402                     Perl_croak(aTHX_ ident_too_long);
5403                 Copy(s, d, t - s, char);
5404                 d += t - s;
5405                 s = t;
5406             }
5407             else
5408                 break;
5409         }
5410     }
5411     *d = '\0';
5412     d = dest;
5413     if (*d) {
5414         if (PL_lex_state != LEX_NORMAL)
5415             PL_lex_state = LEX_INTERPENDMAYBE;
5416         return s;
5417     }
5418     if (*s == '$' && s[1] &&
5419         (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5420     {
5421         return s;
5422     }
5423     if (*s == '{') {
5424         bracket = s;
5425         s++;
5426     }
5427     else if (ck_uni)
5428         check_uni();
5429     if (s < send)
5430         *d = *s++;
5431     d[1] = '\0';
5432     if (*d == '^' && *s && isCONTROLVAR(*s)) {
5433         *d = toCTRL(*s);
5434         s++;
5435     }
5436     if (bracket) {
5437         if (isSPACE(s[-1])) {
5438             while (s < send) {
5439                 char ch = *s++;
5440                 if (ch != ' ' && ch != '\t') {
5441                     *d = ch;
5442                     break;
5443                 }
5444             }
5445         }
5446         if (isIDFIRST_lazy(d)) {
5447             d++;
5448             if (UTF) {
5449                 e = s;
5450                 while (e < send && isALNUM_lazy(e) || *e == ':') {
5451                     e += UTF8SKIP(e);
5452                     while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5453                         e += UTF8SKIP(e);
5454                 }
5455                 Copy(s, d, e - s, char);
5456                 d += e - s;
5457                 s = e;
5458             }
5459             else {
5460                 while ((isALNUM(*s) || *s == ':') && d < e)
5461                     *d++ = *s++;
5462                 if (d >= e)
5463                     Perl_croak(aTHX_ ident_too_long);
5464             }
5465             *d = '\0';
5466             while (s < send && (*s == ' ' || *s == '\t')) s++;
5467             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5468                 dTHR;                   /* only for ckWARN */
5469                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5470                     char *brack = *s == '[' ? "[...]" : "{...}";
5471                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
5472                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5473                         funny, dest, brack, funny, dest, brack);
5474                 }
5475                 PL_lex_fakebrack = PL_lex_brackets+1;
5476                 bracket++;
5477                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5478                 return s;
5479             }
5480         }
5481         /* Handle extended ${^Foo} variables
5482          * 1999-02-27 mjd-perl-patch@plover.com */
5483         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5484                  && isALNUM(*s))
5485         {
5486             d++;
5487             while (isALNUM(*s) && d < e) {
5488                 *d++ = *s++;
5489             }
5490             if (d >= e)
5491                 Perl_croak(aTHX_ ident_too_long);
5492             *d = '\0';
5493         }
5494         if (*s == '}') {
5495             s++;
5496             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5497                 PL_lex_state = LEX_INTERPEND;
5498             if (funny == '#')
5499                 funny = '@';
5500             if (PL_lex_state == LEX_NORMAL) {
5501                 dTHR;                   /* only for ckWARN */
5502                 if (ckWARN(WARN_AMBIGUOUS) &&
5503                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5504                 {
5505                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
5506                         "Ambiguous use of %c{%s} resolved to %c%s",
5507                         funny, dest, funny, dest);
5508                 }
5509             }
5510         }
5511         else {
5512             s = bracket;                /* let the parser handle it */
5513             *dest = '\0';
5514         }
5515     }
5516     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5517         PL_lex_state = LEX_INTERPEND;
5518     return s;
5519 }
5520
5521 void
5522 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5523 {
5524     if (ch == 'i')
5525         *pmfl |= PMf_FOLD;
5526     else if (ch == 'g')
5527         *pmfl |= PMf_GLOBAL;
5528     else if (ch == 'c')
5529         *pmfl |= PMf_CONTINUE;
5530     else if (ch == 'o')
5531         *pmfl |= PMf_KEEP;
5532     else if (ch == 'm')
5533         *pmfl |= PMf_MULTILINE;
5534     else if (ch == 's')
5535         *pmfl |= PMf_SINGLELINE;
5536     else if (ch == 'x')
5537         *pmfl |= PMf_EXTENDED;
5538 }
5539
5540 STATIC char *
5541 S_scan_pat(pTHX_ char *start, I32 type)
5542 {
5543     PMOP *pm;
5544     char *s;
5545
5546     s = scan_str(start);
5547     if (!s) {
5548         if (PL_lex_stuff)
5549             SvREFCNT_dec(PL_lex_stuff);
5550         PL_lex_stuff = Nullsv;
5551         Perl_croak(aTHX_ "Search pattern not terminated");
5552     }
5553
5554     pm = (PMOP*)newPMOP(type, 0);
5555     if (PL_multi_open == '?')
5556         pm->op_pmflags |= PMf_ONCE;
5557     if(type == OP_QR) {
5558         while (*s && strchr("iomsx", *s))
5559             pmflag(&pm->op_pmflags,*s++);
5560     }
5561     else {
5562         while (*s && strchr("iogcmsx", *s))
5563             pmflag(&pm->op_pmflags,*s++);
5564     }
5565     pm->op_pmpermflags = pm->op_pmflags;
5566
5567     PL_lex_op = (OP*)pm;
5568     yylval.ival = OP_MATCH;
5569     return s;
5570 }
5571
5572 STATIC char *
5573 S_scan_subst(pTHX_ char *start)
5574 {
5575     register char *s;
5576     register PMOP *pm;
5577     I32 first_start;
5578     I32 es = 0;
5579
5580     yylval.ival = OP_NULL;
5581
5582     s = scan_str(start);
5583
5584     if (!s) {
5585         if (PL_lex_stuff)
5586             SvREFCNT_dec(PL_lex_stuff);
5587         PL_lex_stuff = Nullsv;
5588         Perl_croak(aTHX_ "Substitution pattern not terminated");
5589     }
5590
5591     if (s[-1] == PL_multi_open)
5592         s--;
5593
5594     first_start = PL_multi_start;
5595     s = scan_str(s);
5596     if (!s) {
5597         if (PL_lex_stuff)
5598             SvREFCNT_dec(PL_lex_stuff);
5599         PL_lex_stuff = Nullsv;
5600         if (PL_lex_repl)
5601             SvREFCNT_dec(PL_lex_repl);
5602         PL_lex_repl = Nullsv;
5603         Perl_croak(aTHX_ "Substitution replacement not terminated");
5604     }
5605     PL_multi_start = first_start;       /* so whole substitution is taken together */
5606
5607     pm = (PMOP*)newPMOP(OP_SUBST, 0);
5608     while (*s) {
5609         if (*s == 'e') {
5610             s++;
5611             es++;
5612         }
5613         else if (strchr("iogcmsx", *s))
5614             pmflag(&pm->op_pmflags,*s++);
5615         else
5616             break;
5617     }
5618
5619     if (es) {
5620         SV *repl;
5621         PL_sublex_info.super_bufptr = s;
5622         PL_sublex_info.super_bufend = PL_bufend;
5623         PL_multi_end = 0;
5624         pm->op_pmflags |= PMf_EVAL;
5625         repl = newSVpvn("",0);
5626         while (es-- > 0)
5627             sv_catpv(repl, es ? "eval " : "do ");
5628         sv_catpvn(repl, "{ ", 2);
5629         sv_catsv(repl, PL_lex_repl);
5630         sv_catpvn(repl, " };", 2);
5631         SvEVALED_on(repl);
5632         SvREFCNT_dec(PL_lex_repl);
5633         PL_lex_repl = repl;
5634     }
5635
5636     pm->op_pmpermflags = pm->op_pmflags;
5637     PL_lex_op = (OP*)pm;
5638     yylval.ival = OP_SUBST;
5639     return s;
5640 }
5641
5642 STATIC char *
5643 S_scan_trans(pTHX_ char *start)
5644 {
5645     register char* s;
5646     OP *o;
5647     short *tbl;
5648     I32 squash;
5649     I32 del;
5650     I32 complement;
5651     I32 utf8;
5652     I32 count = 0;
5653
5654     yylval.ival = OP_NULL;
5655
5656     s = scan_str(start);
5657     if (!s) {
5658         if (PL_lex_stuff)
5659             SvREFCNT_dec(PL_lex_stuff);
5660         PL_lex_stuff = Nullsv;
5661         Perl_croak(aTHX_ "Transliteration pattern not terminated");
5662     }
5663     if (s[-1] == PL_multi_open)
5664         s--;
5665
5666     s = scan_str(s);
5667     if (!s) {
5668         if (PL_lex_stuff)
5669             SvREFCNT_dec(PL_lex_stuff);
5670         PL_lex_stuff = Nullsv;
5671         if (PL_lex_repl)
5672             SvREFCNT_dec(PL_lex_repl);
5673         PL_lex_repl = Nullsv;
5674         Perl_croak(aTHX_ "Transliteration replacement not terminated");
5675     }
5676
5677     if (UTF) {
5678         o = newSVOP(OP_TRANS, 0, 0);
5679         utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5680     }
5681     else {
5682         New(803,tbl,256,short);
5683         o = newPVOP(OP_TRANS, 0, (char*)tbl);
5684         utf8 = 0;
5685     }
5686
5687     complement = del = squash = 0;
5688     while (strchr("cdsCU", *s)) {
5689         if (*s == 'c')
5690             complement = OPpTRANS_COMPLEMENT;
5691         else if (*s == 'd')
5692             del = OPpTRANS_DELETE;
5693         else if (*s == 's')
5694             squash = OPpTRANS_SQUASH;
5695         else {
5696             switch (count++) {
5697             case 0:
5698                 if (*s == 'C')
5699                     utf8 &= ~OPpTRANS_FROM_UTF;
5700                 else
5701                     utf8 |= OPpTRANS_FROM_UTF;
5702                 break;
5703             case 1:
5704                 if (*s == 'C')
5705                     utf8 &= ~OPpTRANS_TO_UTF;
5706                 else
5707                     utf8 |= OPpTRANS_TO_UTF;
5708                 break;
5709             default:
5710                 Perl_croak(aTHX_ "Too many /C and /U options");
5711             }
5712         }
5713         s++;
5714     }
5715     o->op_private = del|squash|complement|utf8;
5716
5717     PL_lex_op = o;
5718     yylval.ival = OP_TRANS;
5719     return s;
5720 }
5721
5722 STATIC char *
5723 S_scan_heredoc(pTHX_ register char *s)
5724 {
5725     dTHR;
5726     SV *herewas;
5727     I32 op_type = OP_SCALAR;
5728     I32 len;
5729     SV *tmpstr;
5730     char term;
5731     register char *d;
5732     register char *e;
5733     char *peek;
5734     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5735
5736     s += 2;
5737     d = PL_tokenbuf;
5738     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5739     if (!outer)
5740         *d++ = '\n';
5741     for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5742     if (*peek && strchr("`'\"",*peek)) {
5743         s = peek;
5744         term = *s++;
5745         s = delimcpy(d, e, s, PL_bufend, term, &len);
5746         d += len;
5747         if (s < PL_bufend)
5748             s++;
5749     }
5750     else {
5751         if (*s == '\\')
5752             s++, term = '\'';
5753         else
5754             term = '"';
5755         if (!isALNUM_lazy(s))
5756             deprecate("bare << to mean <<\"\"");
5757         for (; isALNUM_lazy(s); s++) {
5758             if (d < e)
5759                 *d++ = *s;
5760         }
5761     }
5762     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5763         Perl_croak(aTHX_ "Delimiter for here document is too long");
5764     *d++ = '\n';
5765     *d = '\0';
5766     len = d - PL_tokenbuf;
5767 #ifndef PERL_STRICT_CR
5768     d = strchr(s, '\r');
5769     if (d) {
5770         char *olds = s;
5771         s = d;
5772         while (s < PL_bufend) {
5773             if (*s == '\r') {
5774                 *d++ = '\n';
5775                 if (*++s == '\n')
5776                     s++;
5777             }
5778             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
5779                 *d++ = *s++;
5780                 s++;
5781             }
5782             else
5783                 *d++ = *s++;
5784         }
5785         *d = '\0';
5786         PL_bufend = d;
5787         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5788         s = olds;
5789     }
5790 #endif
5791     d = "\n";
5792     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5793         herewas = newSVpvn(s,PL_bufend-s);
5794     else
5795         s--, herewas = newSVpvn(s,d-s);
5796     s += SvCUR(herewas);
5797
5798     tmpstr = NEWSV(87,79);
5799     sv_upgrade(tmpstr, SVt_PVIV);
5800     if (term == '\'') {
5801         op_type = OP_CONST;
5802         SvIVX(tmpstr) = -1;
5803     }
5804     else if (term == '`') {
5805         op_type = OP_BACKTICK;
5806         SvIVX(tmpstr) = '\\';
5807     }
5808
5809     CLINE;
5810     PL_multi_start = PL_curcop->cop_line;
5811     PL_multi_open = PL_multi_close = '<';
5812     term = *PL_tokenbuf;
5813     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5814         char *bufptr = PL_sublex_info.super_bufptr;
5815         char *bufend = PL_sublex_info.super_bufend;
5816         char *olds = s - SvCUR(herewas);
5817         s = strchr(bufptr, '\n');
5818         if (!s)
5819             s = bufend;
5820         d = s;
5821         while (s < bufend &&
5822           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5823             if (*s++ == '\n')
5824                 PL_curcop->cop_line++;
5825         }
5826         if (s >= bufend) {
5827             PL_curcop->cop_line = PL_multi_start;
5828             missingterm(PL_tokenbuf);
5829         }
5830         sv_setpvn(herewas,bufptr,d-bufptr+1);
5831         sv_setpvn(tmpstr,d+1,s-d);
5832         s += len - 1;
5833         sv_catpvn(herewas,s,bufend-s);
5834         (void)strcpy(bufptr,SvPVX(herewas));
5835
5836         s = olds;
5837         goto retval;
5838     }
5839     else if (!outer) {
5840         d = s;
5841         while (s < PL_bufend &&
5842           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5843             if (*s++ == '\n')
5844                 PL_curcop->cop_line++;
5845         }
5846         if (s >= PL_bufend) {
5847             PL_curcop->cop_line = PL_multi_start;
5848             missingterm(PL_tokenbuf);
5849         }
5850         sv_setpvn(tmpstr,d+1,s-d);
5851         s += len - 1;
5852         PL_curcop->cop_line++;  /* the preceding stmt passes a newline */
5853
5854         sv_catpvn(herewas,s,PL_bufend-s);
5855         sv_setsv(PL_linestr,herewas);
5856         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5857         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5858     }
5859     else
5860         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
5861     while (s >= PL_bufend) {    /* multiple line string? */
5862         if (!outer ||
5863          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5864             PL_curcop->cop_line = PL_multi_start;
5865             missingterm(PL_tokenbuf);
5866         }
5867         PL_curcop->cop_line++;
5868         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5869 #ifndef PERL_STRICT_CR
5870         if (PL_bufend - PL_linestart >= 2) {
5871             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5872                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5873             {
5874                 PL_bufend[-2] = '\n';
5875                 PL_bufend--;
5876                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5877             }
5878             else if (PL_bufend[-1] == '\r')
5879                 PL_bufend[-1] = '\n';
5880         }
5881         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5882             PL_bufend[-1] = '\n';
5883 #endif
5884         if (PERLDB_LINE && PL_curstash != PL_debstash) {
5885             SV *sv = NEWSV(88,0);
5886
5887             sv_upgrade(sv, SVt_PVMG);
5888             sv_setsv(sv,PL_linestr);
5889             av_store(GvAV(PL_curcop->cop_filegv),
5890               (I32)PL_curcop->cop_line,sv);
5891         }
5892         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5893             s = PL_bufend - 1;
5894             *s = ' ';
5895             sv_catsv(PL_linestr,herewas);
5896             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5897         }
5898         else {
5899             s = PL_bufend;
5900             sv_catsv(tmpstr,PL_linestr);
5901         }
5902     }
5903     s++;
5904 retval:
5905     PL_multi_end = PL_curcop->cop_line;
5906     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5907         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5908         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5909     }
5910     SvREFCNT_dec(herewas);
5911     PL_lex_stuff = tmpstr;
5912     yylval.ival = op_type;
5913     return s;
5914 }
5915
5916 /* scan_inputsymbol
5917    takes: current position in input buffer
5918    returns: new position in input buffer
5919    side-effects: yylval and lex_op are set.
5920
5921    This code handles:
5922
5923    <>           read from ARGV
5924    <FH>         read from filehandle
5925    <pkg::FH>    read from package qualified filehandle
5926    <pkg'FH>     read from package qualified filehandle
5927    <$fh>        read from filehandle in $fh
5928    <*.h>        filename glob
5929
5930 */
5931
5932 STATIC char *
5933 S_scan_inputsymbol(pTHX_ char *start)
5934 {
5935     register char *s = start;           /* current position in buffer */
5936     register char *d;
5937     register char *e;
5938     char *end;
5939     I32 len;
5940
5941     d = PL_tokenbuf;                    /* start of temp holding space */
5942     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
5943     end = strchr(s, '\n');
5944     if (!end)
5945         end = PL_bufend;
5946     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
5947
5948     /* die if we didn't have space for the contents of the <>,
5949        or if it didn't end, or if we see a newline
5950     */
5951
5952     if (len >= sizeof PL_tokenbuf)
5953         Perl_croak(aTHX_ "Excessively long <> operator");
5954     if (s >= end)
5955         Perl_croak(aTHX_ "Unterminated <> operator");
5956
5957     s++;
5958
5959     /* check for <$fh>
5960        Remember, only scalar variables are interpreted as filehandles by
5961        this code.  Anything more complex (e.g., <$fh{$num}>) will be
5962        treated as a glob() call.
5963        This code makes use of the fact that except for the $ at the front,
5964        a scalar variable and a filehandle look the same.
5965     */
5966     if (*d == '$' && d[1]) d++;
5967
5968     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5969     while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5970         d++;
5971
5972     /* If we've tried to read what we allow filehandles to look like, and
5973        there's still text left, then it must be a glob() and not a getline.
5974        Use scan_str to pull out the stuff between the <> and treat it
5975        as nothing more than a string.
5976     */
5977
5978     if (d - PL_tokenbuf != len) {
5979         yylval.ival = OP_GLOB;
5980         set_csh();
5981         s = scan_str(start);
5982         if (!s)
5983            Perl_croak(aTHX_ "Glob not terminated");
5984         return s;
5985     }
5986     else {
5987         /* we're in a filehandle read situation */
5988         d = PL_tokenbuf;
5989
5990         /* turn <> into <ARGV> */
5991         if (!len)
5992             (void)strcpy(d,"ARGV");
5993
5994         /* if <$fh>, create the ops to turn the variable into a
5995            filehandle
5996         */
5997         if (*d == '$') {
5998             I32 tmp;
5999
6000             /* try to find it in the pad for this block, otherwise find
6001                add symbol table ops
6002             */
6003             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6004                 OP *o = newOP(OP_PADSV, 0);
6005                 o->op_targ = tmp;
6006                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6007             }
6008             else {
6009                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6010                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6011                                             newUNOP(OP_RV2SV, 0,
6012                                                 newGVOP(OP_GV, 0, gv)));
6013             }
6014             PL_lex_op->op_flags |= OPf_SPECIAL;
6015             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6016             yylval.ival = OP_NULL;
6017         }
6018
6019         /* If it's none of the above, it must be a literal filehandle
6020            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6021         else {
6022             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6023             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6024             yylval.ival = OP_NULL;
6025         }
6026     }
6027
6028     return s;
6029 }
6030
6031
6032 /* scan_str
6033    takes: start position in buffer
6034    returns: position to continue reading from buffer
6035    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6036         updates the read buffer.
6037
6038    This subroutine pulls a string out of the input.  It is called for:
6039         q               single quotes           q(literal text)
6040         '               single quotes           'literal text'
6041         qq              double quotes           qq(interpolate $here please)
6042         "               double quotes           "interpolate $here please"
6043         qx              backticks               qx(/bin/ls -l)
6044         `               backticks               `/bin/ls -l`
6045         qw              quote words             @EXPORT_OK = qw( func() $spam )
6046         m//             regexp match            m/this/
6047         s///            regexp substitute       s/this/that/
6048         tr///           string transliterate    tr/this/that/
6049         y///            string transliterate    y/this/that/
6050         ($*@)           sub prototypes          sub foo ($)
6051         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6052
6053    In most of these cases (all but <>, patterns and transliterate)
6054    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6055    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6056    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6057    calls scan_str().
6058
6059    It skips whitespace before the string starts, and treats the first
6060    character as the delimiter.  If the delimiter is one of ([{< then
6061    the corresponding "close" character )]}> is used as the closing
6062    delimiter.  It allows quoting of delimiters, and if the string has
6063    balanced delimiters ([{<>}]) it allows nesting.
6064
6065    The lexer always reads these strings into lex_stuff, except in the
6066    case of the operators which take *two* arguments (s/// and tr///)
6067    when it checks to see if lex_stuff is full (presumably with the 1st
6068    arg to s or tr) and if so puts the string into lex_repl.
6069
6070 */
6071
6072 STATIC char *
6073 S_scan_str(pTHX_ char *start)
6074 {
6075     dTHR;
6076     SV *sv;                             /* scalar value: string */
6077     char *tmps;                         /* temp string, used for delimiter matching */
6078     register char *s = start;           /* current position in the buffer */
6079     register char term;                 /* terminating character */
6080     register char *to;                  /* current position in the sv's data */
6081     I32 brackets = 1;                   /* bracket nesting level */
6082
6083     /* skip space before the delimiter */
6084     if (isSPACE(*s))
6085         s = skipspace(s);
6086
6087     /* mark where we are, in case we need to report errors */
6088     CLINE;
6089
6090     /* after skipping whitespace, the next character is the terminator */
6091     term = *s;
6092     /* mark where we are */
6093     PL_multi_start = PL_curcop->cop_line;
6094     PL_multi_open = term;
6095
6096     /* find corresponding closing delimiter */
6097     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6098         term = tmps[5];
6099     PL_multi_close = term;
6100
6101     /* create a new SV to hold the contents.  87 is leak category, I'm
6102        assuming.  79 is the SV's initial length.  What a random number. */
6103     sv = NEWSV(87,79);
6104     sv_upgrade(sv, SVt_PVIV);
6105     SvIVX(sv) = term;
6106     (void)SvPOK_only(sv);               /* validate pointer */
6107
6108     /* move past delimiter and try to read a complete string */
6109     s++;
6110     for (;;) {
6111         /* extend sv if need be */
6112         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6113         /* set 'to' to the next character in the sv's string */
6114         to = SvPVX(sv)+SvCUR(sv);
6115
6116         /* if open delimiter is the close delimiter read unbridle */
6117         if (PL_multi_open == PL_multi_close) {
6118             for (; s < PL_bufend; s++,to++) {
6119                 /* embedded newlines increment the current line number */
6120                 if (*s == '\n' && !PL_rsfp)
6121                     PL_curcop->cop_line++;
6122                 /* handle quoted delimiters */
6123                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6124                     if (s[1] == term)
6125                         s++;
6126                 /* any other quotes are simply copied straight through */
6127                     else
6128                         *to++ = *s++;
6129                 }
6130                 /* terminate when run out of buffer (the for() condition), or
6131                    have found the terminator */
6132                 else if (*s == term)
6133                     break;
6134                 *to = *s;
6135             }
6136         }
6137
6138         /* if the terminator isn't the same as the start character (e.g.,
6139            matched brackets), we have to allow more in the quoting, and
6140            be prepared for nested brackets.
6141         */
6142         else {
6143             /* read until we run out of string, or we find the terminator */
6144             for (; s < PL_bufend; s++,to++) {
6145                 /* embedded newlines increment the line count */
6146                 if (*s == '\n' && !PL_rsfp)
6147                     PL_curcop->cop_line++;
6148                 /* backslashes can escape the open or closing characters */
6149                 if (*s == '\\' && s+1 < PL_bufend) {
6150                     if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
6151                         s++;
6152                     else
6153                         *to++ = *s++;
6154                 }
6155                 /* allow nested opens and closes */
6156                 else if (*s == PL_multi_close && --brackets <= 0)
6157                     break;
6158                 else if (*s == PL_multi_open)
6159                     brackets++;
6160                 *to = *s;
6161             }
6162         }
6163         /* terminate the copied string and update the sv's end-of-string */
6164         *to = '\0';
6165         SvCUR_set(sv, to - SvPVX(sv));
6166
6167         /*
6168          * this next chunk reads more into the buffer if we're not done yet
6169          */
6170
6171         if (s < PL_bufend) break;       /* handle case where we are done yet :-) */
6172
6173 #ifndef PERL_STRICT_CR
6174         if (to - SvPVX(sv) >= 2) {
6175             if ((to[-2] == '\r' && to[-1] == '\n') ||
6176                 (to[-2] == '\n' && to[-1] == '\r'))
6177             {
6178                 to[-2] = '\n';
6179                 to--;
6180                 SvCUR_set(sv, to - SvPVX(sv));
6181             }
6182             else if (to[-1] == '\r')
6183                 to[-1] = '\n';
6184         }
6185         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6186             to[-1] = '\n';
6187 #endif
6188
6189         /* if we're out of file, or a read fails, bail and reset the current
6190            line marker so we can report where the unterminated string began
6191         */
6192         if (!PL_rsfp ||
6193          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6194             sv_free(sv);
6195             PL_curcop->cop_line = PL_multi_start;
6196             return Nullch;
6197         }
6198         /* we read a line, so increment our line counter */
6199         PL_curcop->cop_line++;
6200
6201         /* update debugger info */
6202         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6203             SV *sv = NEWSV(88,0);
6204
6205             sv_upgrade(sv, SVt_PVMG);
6206             sv_setsv(sv,PL_linestr);
6207             av_store(GvAV(PL_curcop->cop_filegv),
6208               (I32)PL_curcop->cop_line, sv);
6209         }
6210
6211         /* having changed the buffer, we must update PL_bufend */
6212         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6213     }
6214
6215     /* at this point, we have successfully read the delimited string */
6216
6217     PL_multi_end = PL_curcop->cop_line;
6218     s++;
6219
6220     /* if we allocated too much space, give some back */
6221     if (SvCUR(sv) + 5 < SvLEN(sv)) {
6222         SvLEN_set(sv, SvCUR(sv) + 1);
6223         Renew(SvPVX(sv), SvLEN(sv), char);
6224     }
6225
6226     /* decide whether this is the first or second quoted string we've read
6227        for this op
6228     */
6229
6230     if (PL_lex_stuff)
6231         PL_lex_repl = sv;
6232     else
6233         PL_lex_stuff = sv;
6234     return s;
6235 }
6236
6237 /*
6238   scan_num
6239   takes: pointer to position in buffer
6240   returns: pointer to new position in buffer
6241   side-effects: builds ops for the constant in yylval.op
6242
6243   Read a number in any of the formats that Perl accepts:
6244
6245   0(x[0-7A-F]+)|([0-7]+)|(b[01])
6246   [\d_]+(\.[\d_]*)?[Ee](\d+)
6247
6248   Underbars (_) are allowed in decimal numbers.  If -w is on,
6249   underbars before a decimal point must be at three digit intervals.
6250
6251   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6252   thing it reads.
6253
6254   If it reads a number without a decimal point or an exponent, it will
6255   try converting the number to an integer and see if it can do so
6256   without loss of precision.
6257 */
6258
6259 char *
6260 Perl_scan_num(pTHX_ char *start)
6261 {
6262     register char *s = start;           /* current position in buffer */
6263     register char *d;                   /* destination in temp buffer */
6264     register char *e;                   /* end of temp buffer */
6265     IV tryiv;                           /* used to see if it can be an IV */
6266     NV value;                           /* number read, as a double */
6267     SV *sv;                             /* place to put the converted number */
6268     bool floatit;                       /* boolean: int or float? */
6269     char *lastub = 0;                   /* position of last underbar */
6270     static char number_too_long[] = "Number too long";
6271
6272     /* We use the first character to decide what type of number this is */
6273
6274     switch (*s) {
6275     default:
6276       Perl_croak(aTHX_ "panic: scan_num");
6277
6278     /* if it starts with a 0, it could be an octal number, a decimal in
6279        0.13 disguise, or a hexadecimal number, or a binary number.
6280     */
6281     case '0':
6282         {
6283           /* variables:
6284              u          holds the "number so far"
6285              shift      the power of 2 of the base
6286                         (hex == 4, octal == 3, binary == 1)
6287              overflowed was the number more than we can hold?
6288
6289              Shift is used when we add a digit.  It also serves as an "are
6290              we in octal/hex/binary?" indicator to disallow hex characters
6291              when in octal mode.
6292            */
6293             dTHR;
6294             NV n = 0.0;
6295             UV u = 0;
6296             I32 shift;
6297             bool overflowed = FALSE;
6298             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6299             static char* bases[5] = { "", "binary", "", "octal",
6300                                       "hexadecimal" };
6301             static char* Bases[5] = { "", "Binary", "", "Octal",
6302                                       "Hexadecimal" };
6303             static char *maxima[5] = { "",
6304                                        "0b11111111111111111111111111111111",
6305                                        "",
6306                                        "037777777777",
6307                                        "0xffffffff" };
6308             char *base, *Base, *max;
6309
6310             /* check for hex */
6311             if (s[1] == 'x') {
6312                 shift = 4;
6313                 s += 2;
6314             } else if (s[1] == 'b') {
6315                 shift = 1;
6316                 s += 2;
6317             }
6318             /* check for a decimal in disguise */
6319             else if (s[1] == '.')
6320                 goto decimal;
6321             /* so it must be octal */
6322             else
6323                 shift = 3;
6324
6325             base = bases[shift];
6326             Base = Bases[shift];
6327             max  = maxima[shift];
6328
6329             /* read the rest of the number */
6330             for (;;) {
6331                 /* x is used in the overflow test,
6332                    b is the digit we're adding on. */
6333                 UV x, b;
6334
6335                 switch (*s) {
6336
6337                 /* if we don't mention it, we're done */
6338                 default:
6339                     goto out;
6340
6341                 /* _ are ignored */
6342                 case '_':
6343                     s++;
6344                     break;
6345
6346                 /* 8 and 9 are not octal */
6347                 case '8': case '9':
6348                     if (shift == 3)
6349                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6350                     else
6351                         if (shift == 1)
6352                             yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6353                     /* FALL THROUGH */
6354
6355                 /* octal digits */
6356                 case '2': case '3': case '4':
6357                 case '5': case '6': case '7':
6358                     if (shift == 1)
6359                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6360                     /* FALL THROUGH */
6361
6362                 case '0': case '1':
6363                     b = *s++ & 15;              /* ASCII digit -> value of digit */
6364                     goto digit;
6365
6366                 /* hex digits */
6367                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6368                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6369                     /* make sure they said 0x */
6370                     if (shift != 4)
6371                         goto out;
6372                     b = (*s++ & 7) + 9;
6373
6374                     /* Prepare to put the digit we have onto the end
6375                        of the number so far.  We check for overflows.
6376                     */
6377
6378                   digit:
6379                     if (!overflowed) {
6380                         x = u << shift; /* make room for the digit */
6381
6382                         if ((x >> shift) != u
6383                             && !(PL_hints & HINT_NEW_BINARY)) {
6384                             dTHR;
6385                             overflowed = TRUE;
6386                             n = (NV) u;
6387                             if (ckWARN_d(WARN_UNSAFE))
6388                                 Perl_warner(aTHX_ ((shift == 3) ?
6389                                                    WARN_OCTAL : WARN_UNSAFE),
6390                                             "Integer overflow in %s number",
6391                                             base);
6392                         } else
6393                             u = x | b;          /* add the digit to the end */
6394                     }
6395                     if (overflowed) {
6396                         n *= nvshift[shift];
6397                         /* If an NV has not enough bits in its
6398                          * mantissa to represent an UV this summing of
6399                          * small low-order numbers is a waste of time
6400                          * (because the NV cannot preserve the
6401                          * low-order bits anyway): we could just
6402                          * remember when did we overflow and in the
6403                          * end just multiply n by the right
6404                          * amount. */
6405                         n += (NV) b;
6406                     }
6407                     break;
6408                 }
6409             }
6410
6411           /* if we get here, we had success: make a scalar value from
6412              the number.
6413           */
6414           out:
6415             sv = NEWSV(92,0);
6416             if (overflowed) {
6417                 dTHR;
6418                 if (ckWARN(WARN_UNSAFE) && n > 4294967295.0)
6419                     Perl_warner(aTHX_ WARN_UNSAFE,
6420                                 "%s number > %s non-portable",
6421                                 Base, max);
6422                 sv_setnv(sv, n);
6423             }
6424             else {
6425 #if UV_SIZEOF > 4
6426                 dTHR;
6427                 if (ckWARN(WARN_UNSAFE) && u > 0xffffffff)
6428                     Perl_warner(aTHX_ WARN_UNSAFE,
6429                                 "%s number > %s non-portable",
6430                                 Base, max);
6431 #endif
6432                 sv_setuv(sv, u);
6433             }
6434             if (PL_hints & HINT_NEW_BINARY)
6435                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6436         }
6437         break;
6438
6439     /*
6440       handle decimal numbers.
6441       we're also sent here when we read a 0 as the first digit
6442     */
6443     case '1': case '2': case '3': case '4': case '5':
6444     case '6': case '7': case '8': case '9': case '.':
6445       decimal:
6446         d = PL_tokenbuf;
6447         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6448         floatit = FALSE;
6449
6450         /* read next group of digits and _ and copy into d */
6451         while (isDIGIT(*s) || *s == '_') {
6452             /* skip underscores, checking for misplaced ones
6453                if -w is on
6454             */
6455             if (*s == '_') {
6456                 dTHR;                   /* only for ckWARN */
6457                 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6458                     Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6459                 lastub = ++s;
6460             }
6461             else {
6462                 /* check for end of fixed-length buffer */
6463                 if (d >= e)
6464                     Perl_croak(aTHX_ number_too_long);
6465                 /* if we're ok, copy the character */
6466                 *d++ = *s++;
6467             }
6468         }
6469
6470         /* final misplaced underbar check */
6471         if (lastub && s - lastub != 3) {
6472             dTHR;
6473             if (ckWARN(WARN_SYNTAX))
6474                 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6475         }
6476
6477         /* read a decimal portion if there is one.  avoid
6478            3..5 being interpreted as the number 3. followed
6479            by .5
6480         */
6481         if (*s == '.' && s[1] != '.') {
6482             floatit = TRUE;
6483             *d++ = *s++;
6484
6485             /* copy, ignoring underbars, until we run out of
6486                digits.  Note: no misplaced underbar checks!
6487             */
6488             for (; isDIGIT(*s) || *s == '_'; s++) {
6489                 /* fixed length buffer check */
6490                 if (d >= e)
6491                     Perl_croak(aTHX_ number_too_long);
6492                 if (*s != '_')
6493                     *d++ = *s;
6494             }
6495         }
6496
6497         /* read exponent part, if present */
6498         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6499             floatit = TRUE;
6500             s++;
6501
6502             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6503             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
6504
6505             /* allow positive or negative exponent */
6506             if (*s == '+' || *s == '-')
6507                 *d++ = *s++;
6508
6509             /* read digits of exponent (no underbars :-) */
6510             while (isDIGIT(*s)) {
6511                 if (d >= e)
6512                     Perl_croak(aTHX_ number_too_long);
6513                 *d++ = *s++;
6514             }
6515         }
6516
6517         /* terminate the string */
6518         *d = '\0';
6519
6520         /* make an sv from the string */
6521         sv = NEWSV(92,0);
6522
6523         value = Atof(PL_tokenbuf);
6524
6525         /*
6526            See if we can make do with an integer value without loss of
6527            precision.  We use I_V to cast to an int, because some
6528            compilers have issues.  Then we try casting it back and see
6529            if it was the same.  We only do this if we know we
6530            specifically read an integer.
6531
6532            Note: if floatit is true, then we don't need to do the
6533            conversion at all.
6534         */
6535         tryiv = I_V(value);
6536         if (!floatit && (NV)tryiv == value)
6537             sv_setiv(sv, tryiv);
6538         else
6539             sv_setnv(sv, value);
6540         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6541                        (PL_hints & HINT_NEW_INTEGER) )
6542             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6543                               (floatit ? "float" : "integer"),
6544                               sv, Nullsv, NULL);
6545         break;
6546     }
6547
6548     /* make the op for the constant and return */
6549
6550     yylval.opval = newSVOP(OP_CONST, 0, sv);
6551
6552     return s;
6553 }
6554
6555 STATIC char *
6556 S_scan_formline(pTHX_ register char *s)
6557 {
6558     dTHR;
6559     register char *eol;
6560     register char *t;
6561     SV *stuff = newSVpvn("",0);
6562     bool needargs = FALSE;
6563
6564     while (!needargs) {
6565         if (*s == '.' || *s == '}') {
6566             /*SUPPRESS 530*/
6567 #ifdef PERL_STRICT_CR
6568             for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6569 #else
6570             for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6571 #endif
6572             if (*t == '\n' || t == PL_bufend)
6573                 break;
6574         }
6575         if (PL_in_eval && !PL_rsfp) {
6576             eol = strchr(s,'\n');
6577             if (!eol++)
6578                 eol = PL_bufend;
6579         }
6580         else
6581             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6582         if (*s != '#') {
6583             for (t = s; t < eol; t++) {
6584                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6585                     needargs = FALSE;
6586                     goto enough;        /* ~~ must be first line in formline */
6587                 }
6588                 if (*t == '@' || *t == '^')
6589                     needargs = TRUE;
6590             }
6591             sv_catpvn(stuff, s, eol-s);
6592         }
6593         s = eol;
6594         if (PL_rsfp) {
6595             s = filter_gets(PL_linestr, PL_rsfp, 0);
6596             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6597             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6598             if (!s) {
6599                 s = PL_bufptr;
6600                 yyerror("Format not terminated");
6601                 break;
6602             }
6603         }
6604         incline(s);
6605     }
6606   enough:
6607     if (SvCUR(stuff)) {
6608         PL_expect = XTERM;
6609         if (needargs) {
6610             PL_lex_state = LEX_NORMAL;
6611             PL_nextval[PL_nexttoke].ival = 0;
6612             force_next(',');
6613         }
6614         else
6615             PL_lex_state = LEX_FORMLINE;
6616         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6617         force_next(THING);
6618         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6619         force_next(LSTOP);
6620     }
6621     else {
6622         SvREFCNT_dec(stuff);
6623         PL_lex_formbrack = 0;
6624         PL_bufptr = s;
6625     }
6626     return s;
6627 }
6628
6629 STATIC void
6630 S_set_csh(pTHX)
6631 {
6632 #ifdef CSH
6633     if (!PL_cshlen)
6634         PL_cshlen = strlen(PL_cshname);
6635 #endif
6636 }
6637
6638 I32
6639 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6640 {
6641     dTHR;
6642     I32 oldsavestack_ix = PL_savestack_ix;
6643     CV* outsidecv = PL_compcv;
6644     AV* comppadlist;
6645
6646     if (PL_compcv) {
6647         assert(SvTYPE(PL_compcv) == SVt_PVCV);
6648     }
6649     save_I32(&PL_subline);
6650     save_item(PL_subname);
6651     SAVEI32(PL_padix);
6652     SAVESPTR(PL_curpad);
6653     SAVESPTR(PL_comppad);
6654     SAVESPTR(PL_comppad_name);
6655     SAVESPTR(PL_compcv);
6656     SAVEI32(PL_comppad_name_fill);
6657     SAVEI32(PL_min_intro_pending);
6658     SAVEI32(PL_max_intro_pending);
6659     SAVEI32(PL_pad_reset_pending);
6660
6661     PL_compcv = (CV*)NEWSV(1104,0);
6662     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6663     CvFLAGS(PL_compcv) |= flags;
6664
6665     PL_comppad = newAV();
6666     av_push(PL_comppad, Nullsv);
6667     PL_curpad = AvARRAY(PL_comppad);
6668     PL_comppad_name = newAV();
6669     PL_comppad_name_fill = 0;
6670     PL_min_intro_pending = 0;
6671     PL_padix = 0;
6672     PL_subline = PL_curcop->cop_line;
6673 #ifdef USE_THREADS
6674     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6675     PL_curpad[0] = (SV*)newAV();
6676     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
6677 #endif /* USE_THREADS */
6678
6679     comppadlist = newAV();
6680     AvREAL_off(comppadlist);
6681     av_store(comppadlist, 0, (SV*)PL_comppad_name);
6682     av_store(comppadlist, 1, (SV*)PL_comppad);
6683
6684     CvPADLIST(PL_compcv) = comppadlist;
6685     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6686 #ifdef USE_THREADS
6687     CvOWNER(PL_compcv) = 0;
6688     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6689     MUTEX_INIT(CvMUTEXP(PL_compcv));
6690 #endif /* USE_THREADS */
6691
6692     return oldsavestack_ix;
6693 }
6694
6695 int
6696 Perl_yywarn(pTHX_ char *s)
6697 {
6698     dTHR;
6699     --PL_error_count;
6700     PL_in_eval |= EVAL_WARNONLY;
6701     yyerror(s);
6702     PL_in_eval &= ~EVAL_WARNONLY;
6703     return 0;
6704 }
6705
6706 int
6707 Perl_yyerror(pTHX_ char *s)
6708 {
6709     dTHR;
6710     char *where = NULL;
6711     char *context = NULL;
6712     int contlen = -1;
6713     SV *msg;
6714
6715     if (!yychar || (yychar == ';' && !PL_rsfp))
6716         where = "at EOF";
6717     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6718       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6719         while (isSPACE(*PL_oldoldbufptr))
6720             PL_oldoldbufptr++;
6721         context = PL_oldoldbufptr;
6722         contlen = PL_bufptr - PL_oldoldbufptr;
6723     }
6724     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6725       PL_oldbufptr != PL_bufptr) {
6726         while (isSPACE(*PL_oldbufptr))
6727             PL_oldbufptr++;
6728         context = PL_oldbufptr;
6729         contlen = PL_bufptr - PL_oldbufptr;
6730     }
6731     else if (yychar > 255)
6732         where = "next token ???";
6733     else if ((yychar & 127) == 127) {
6734         if (PL_lex_state == LEX_NORMAL ||
6735            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6736             where = "at end of line";
6737         else if (PL_lex_inpat)
6738             where = "within pattern";
6739         else
6740             where = "within string";
6741     }
6742     else {
6743         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6744         if (yychar < 32)
6745             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6746         else if (isPRINT_LC(yychar))
6747             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6748         else
6749             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6750         where = SvPVX(where_sv);
6751     }
6752     msg = sv_2mortal(newSVpv(s, 0));
6753 #ifdef IV_IS_QUAD
6754     Perl_sv_catpvf(aTHX_ msg, " at %_ line %" PERL_PRId64 ", ",
6755               GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line);
6756 #else
6757     Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6758               GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6759 #endif
6760     if (context)
6761         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6762     else
6763         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6764     if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6765 #ifdef IV_IS_QUAD
6766         Perl_sv_catpvf(aTHX_ msg,
6767         "  (Might be a runaway multi-line %c%c string starting on line %" PERL_\
6768 PRId64 ")\n",
6769                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
6770 #else
6771         Perl_sv_catpvf(aTHX_ msg,
6772         "  (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6773                 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6774 #endif
6775         PL_multi_end = 0;
6776     }
6777     if (PL_in_eval & EVAL_WARNONLY)
6778         Perl_warn(aTHX_ "%_", msg);
6779     else if (PL_in_eval)
6780         sv_catsv(ERRSV, msg);
6781     else
6782         PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6783     if (++PL_error_count >= 10)
6784         Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6785     PL_in_my = 0;
6786     PL_in_my_stash = Nullhv;
6787     return 0;
6788 }
6789
6790
6791 #ifdef PERL_OBJECT
6792 #define NO_XSLOCKS
6793 #include "XSUB.h"
6794 #endif
6795
6796 /*
6797  * restore_rsfp
6798  * Restore a source filter.
6799  */
6800
6801 static void
6802 restore_rsfp(pTHXo_ void *f)
6803 {
6804     PerlIO *fp = (PerlIO*)f;
6805
6806     if (PL_rsfp == PerlIO_stdin())
6807         PerlIO_clearerr(PL_rsfp);
6808     else if (PL_rsfp && (PL_rsfp != fp))
6809         PerlIO_close(PL_rsfp);
6810     PL_rsfp = fp;
6811 }
6812
6813 /*
6814  * restore_expect
6815  * Restores the state of PL_expect when the lexing that begun with a
6816  * start_lex() call has ended.
6817  */
6818
6819 static void
6820 restore_expect(pTHXo_ void *e)
6821 {
6822     /* a safe way to store a small integer in a pointer */
6823     PL_expect = (expectation)((char *)e - PL_tokenbuf);
6824 }
6825
6826 /*
6827  * restore_lex_expect
6828  * Restores the state of PL_lex_expect when the lexing that begun with a
6829  * start_lex() call has ended.
6830  */
6831
6832 static void
6833 restore_lex_expect(pTHXo_ void *e)
6834 {
6835     /* a safe way to store a small integer in a pointer */
6836     PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
6837 }