toke.c

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