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