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