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