toke.c

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