toke.c

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