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