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