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(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
2270     } )
2271
2272   retry:
2273     switch (*s) {
2274     default:
2275         if (isIDFIRST_lazy(s))
2276             goto keylookup;
2277         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2278     case 4:
2279     case 26:
2280         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2281     case 0:
2282         if (!PL_rsfp) {
2283             PL_last_uni = 0;
2284             PL_last_lop = 0;
2285             if (PL_lex_brackets)
2286                 yyerror("Missing right curly or square bracket");
2287             TOKEN(0);
2288         }
2289         if (s++ < PL_bufend)
2290             goto retry;                 /* ignore stray nulls */
2291         PL_last_uni = 0;
2292         PL_last_lop = 0;
2293         if (!PL_in_eval && !PL_preambled) {
2294             PL_preambled = TRUE;
2295             sv_setpv(PL_linestr,incl_perldb());
2296             if (SvCUR(PL_linestr))
2297                 sv_catpv(PL_linestr,";");
2298             if (PL_preambleav){
2299                 while(AvFILLp(PL_preambleav) >= 0) {
2300                     SV *tmpsv = av_shift(PL_preambleav);
2301                     sv_catsv(PL_linestr, tmpsv);
2302                     sv_catpv(PL_linestr, ";");
2303                     sv_free(tmpsv);
2304                 }
2305                 sv_free((SV*)PL_preambleav);
2306                 PL_preambleav = NULL;
2307             }
2308             if (PL_minus_n || PL_minus_p) {
2309                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2310                 if (PL_minus_l)
2311                     sv_catpv(PL_linestr,"chomp;");
2312                 if (PL_minus_a) {
2313                     GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2314                     if (gv)
2315                         GvIMPORTED_AV_on(gv);
2316                     if (PL_minus_F) {
2317                         if (strchr("/'\"", *PL_splitstr)
2318                               && strchr(PL_splitstr + 1, *PL_splitstr))
2319                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2320                         else {
2321                             char delim;
2322                             s = "'~#\200\1'"; /* surely one char is unused...*/
2323                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2324                             delim = *s;
2325                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2326                                       "q" + (delim == '\''), delim);
2327                             for (s = PL_splitstr; *s; s++) {
2328                                 if (*s == '\\')
2329                                     sv_catpvn(PL_linestr, "\\", 1);
2330                                 sv_catpvn(PL_linestr, s, 1);
2331                             }
2332                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2333                         }
2334                     }
2335                     else
2336                         sv_catpv(PL_linestr,"@F=split(' ');");
2337                 }
2338             }
2339             sv_catpv(PL_linestr, "\n");
2340             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2341             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2342             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2343                 SV *sv = NEWSV(85,0);
2344
2345                 sv_upgrade(sv, SVt_PVMG);
2346                 sv_setsv(sv,PL_linestr);
2347                 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2348             }
2349             goto retry;
2350         }
2351         do {
2352             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2353               fake_eof:
2354                 if (PL_rsfp) {
2355                     if (PL_preprocess && !PL_in_eval)
2356                         (void)PerlProc_pclose(PL_rsfp);
2357                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2358                         PerlIO_clearerr(PL_rsfp);
2359                     else
2360                         (void)PerlIO_close(PL_rsfp);
2361                     PL_rsfp = Nullfp;
2362                     PL_doextract = FALSE;
2363                 }
2364                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2365                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2366                     sv_catpv(PL_linestr,";}");
2367                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2368                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2369                     PL_minus_n = PL_minus_p = 0;
2370                     goto retry;
2371                 }
2372                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2373                 sv_setpv(PL_linestr,"");
2374                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2375             }
2376             if (PL_doextract) {
2377                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2378                     PL_doextract = FALSE;
2379
2380                 /* Incest with pod. */
2381                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2382                     sv_setpv(PL_linestr, "");
2383                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2384                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2385                     PL_doextract = FALSE;
2386                 }
2387             }
2388             incline(s);
2389         } while (PL_doextract);
2390         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2391         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2392             SV *sv = NEWSV(85,0);
2393
2394             sv_upgrade(sv, SVt_PVMG);
2395             sv_setsv(sv,PL_linestr);
2396             av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2397         }
2398         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2399         if (PL_curcop->cop_line == 1) {
2400             while (s < PL_bufend && isSPACE(*s))
2401                 s++;
2402             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2403                 s++;
2404             d = Nullch;
2405             if (!PL_in_eval) {
2406                 if (*s == '#' && *(s+1) == '!')
2407                     d = s + 2;
2408 #ifdef ALTERNATE_SHEBANG
2409                 else {
2410                     static char as[] = ALTERNATE_SHEBANG;
2411                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2412                         d = s + (sizeof(as) - 1);
2413                 }
2414 #endif /* ALTERNATE_SHEBANG */
2415             }
2416             if (d) {
2417                 char *ipath;
2418                 char *ipathend;
2419
2420                 while (isSPACE(*d))
2421                     d++;
2422                 ipath = d;
2423                 while (*d && !isSPACE(*d))
2424                     d++;
2425                 ipathend = d;
2426
2427 #ifdef ARG_ZERO_IS_SCRIPT
2428                 if (ipathend > ipath) {
2429                     /*
2430                      * HP-UX (at least) sets argv[0] to the script name,
2431                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2432                      * at least, set argv[0] to the basename of the Perl
2433                      * interpreter. So, having found "#!", we'll set it right.
2434                      */
2435                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2436                     assert(SvPOK(x) || SvGMAGICAL(x));
2437                     if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2438                         sv_setpvn(x, ipath, ipathend - ipath);
2439                         SvSETMAGIC(x);
2440                     }
2441                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2442                 }
2443 #endif /* ARG_ZERO_IS_SCRIPT */
2444
2445                 /*
2446                  * Look for options.
2447                  */
2448                 d = instr(s,"perl -");
2449                 if (!d) {
2450                     d = instr(s,"perl");
2451 #if defined(DOSISH)
2452                     /* avoid getting into infinite loops when shebang
2453                      * line contains "Perl" rather than "perl" */
2454                     if (!d) {
2455                         for (d = ipathend-4; d >= ipath; --d) {
2456                             if ((*d == 'p' || *d == 'P')
2457                                 && !ibcmp(d, "perl", 4))
2458                             {
2459                                 break;
2460                             }
2461                         }
2462                         if (d < ipath)
2463                             d = Nullch;
2464                     }
2465 #endif
2466                 }
2467 #ifdef ALTERNATE_SHEBANG
2468                 /*
2469                  * If the ALTERNATE_SHEBANG on this system starts with a
2470                  * character that can be part of a Perl expression, then if
2471                  * we see it but not "perl", we're probably looking at the
2472                  * start of Perl code, not a request to hand off to some
2473                  * other interpreter.  Similarly, if "perl" is there, but
2474                  * not in the first 'word' of the line, we assume the line
2475                  * contains the start of the Perl program.
2476                  */
2477                 if (d && *s != '#') {
2478                     char *c = ipath;
2479                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2480                         c++;
2481                     if (c < d)
2482                         d = Nullch;     /* "perl" not in first word; ignore */
2483                     else
2484                         *s = '#';       /* Don't try to parse shebang line */
2485                 }
2486 #endif /* ALTERNATE_SHEBANG */
2487                 if (!d &&
2488                     *s == '#' &&
2489                     ipathend > ipath &&
2490                     !PL_minus_c &&
2491                     !instr(s,"indir") &&
2492                     instr(PL_origargv[0],"perl"))
2493                 {
2494                     char **newargv;
2495
2496                     *ipathend = '\0';
2497                     s = ipathend + 1;
2498                     while (s < PL_bufend && isSPACE(*s))
2499                         s++;
2500                     if (s < PL_bufend) {
2501                         Newz(899,newargv,PL_origargc+3,char*);
2502                         newargv[1] = s;
2503                         while (s < PL_bufend && !isSPACE(*s))
2504                             s++;
2505                         *s = '\0';
2506                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2507                     }
2508                     else
2509                         newargv = PL_origargv;
2510                     newargv[0] = ipath;
2511                     PerlProc_execv(ipath, newargv);
2512                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2513                 }
2514                 if (d) {
2515                     U32 oldpdb = PL_perldb;
2516                     bool oldn = PL_minus_n;
2517                     bool oldp = PL_minus_p;
2518
2519                     while (*d && !isSPACE(*d)) d++;
2520                     while (*d == ' ' || *d == '\t') d++;
2521
2522                     if (*d++ == '-') {
2523                         do {
2524                             if (*d == 'M' || *d == 'm') {
2525                                 char *m = d;
2526                                 while (*d && !isSPACE(*d)) d++;
2527                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2528                                       (int)(d - m), m);
2529                             }
2530                             d = moreswitches(d);
2531                         } while (d);
2532                         if (PERLDB_LINE && !oldpdb ||
2533                             ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2534                               /* if we have already added "LINE: while (<>) {",
2535                                  we must not do it again */
2536                         {
2537                             sv_setpv(PL_linestr, "");
2538                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2539                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2540                             PL_preambled = FALSE;
2541                             if (PERLDB_LINE)
2542                                 (void)gv_fetchfile(PL_origfilename);
2543                             goto retry;
2544                         }
2545                     }
2546                 }
2547             }
2548         }
2549         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2550             PL_bufptr = s;
2551             PL_lex_state = LEX_FORMLINE;
2552             return yylex();
2553         }
2554         goto retry;
2555     case '\r':
2556 #ifdef PERL_STRICT_CR
2557         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2558         Perl_croak(aTHX_
2559       "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2560 #endif
2561     case ' ': case '\t': case '\f': case 013:
2562         s++;
2563         goto retry;
2564     case '#':
2565     case '\n':
2566         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2567             d = PL_bufend;
2568             while (s < d && *s != '\n')
2569                 s++;
2570             if (s < d)
2571                 s++;
2572             incline(s);
2573             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2574                 PL_bufptr = s;
2575                 PL_lex_state = LEX_FORMLINE;
2576                 return yylex();
2577             }
2578         }
2579         else {
2580             *s = '\0';
2581             PL_bufend = s;
2582         }
2583         goto retry;
2584     case '-':
2585         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2586             s++;
2587             PL_bufptr = s;
2588             tmp = *s++;
2589
2590             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2591                 s++;
2592
2593             if (strnEQ(s,"=>",2)) {
2594                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2595                 OPERATOR('-');          /* unary minus */
2596             }
2597             PL_last_uni = PL_oldbufptr;
2598             PL_last_lop_op = OP_FTEREAD;        /* good enough */
2599             switch (tmp) {
2600             case 'r': FTST(OP_FTEREAD);
2601             case 'w': FTST(OP_FTEWRITE);
2602             case 'x': FTST(OP_FTEEXEC);
2603             case 'o': FTST(OP_FTEOWNED);
2604             case 'R': FTST(OP_FTRREAD);
2605             case 'W': FTST(OP_FTRWRITE);
2606             case 'X': FTST(OP_FTREXEC);
2607             case 'O': FTST(OP_FTROWNED);
2608             case 'e': FTST(OP_FTIS);
2609             case 'z': FTST(OP_FTZERO);
2610             case 's': FTST(OP_FTSIZE);
2611             case 'f': FTST(OP_FTFILE);
2612             case 'd': FTST(OP_FTDIR);
2613             case 'l': FTST(OP_FTLINK);
2614             case 'p': FTST(OP_FTPIPE);
2615             case 'S': FTST(OP_FTSOCK);
2616             case 'u': FTST(OP_FTSUID);
2617             case 'g': FTST(OP_FTSGID);
2618             case 'k': FTST(OP_FTSVTX);
2619             case 'b': FTST(OP_FTBLK);
2620             case 'c': FTST(OP_FTCHR);
2621             case 't': FTST(OP_FTTTY);
2622             case 'T': FTST(OP_FTTEXT);
2623             case 'B': FTST(OP_FTBINARY);
2624             case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2625             case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2626             case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2627             default:
2628                 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2629                 break;
2630             }
2631         }
2632         tmp = *s++;
2633         if (*s == tmp) {
2634             s++;
2635             if (PL_expect == XOPERATOR)
2636                 TERM(POSTDEC);
2637             else
2638                 OPERATOR(PREDEC);
2639         }
2640         else if (*s == '>') {
2641             s++;
2642             s = skipspace(s);
2643             if (isIDFIRST_lazy(s)) {
2644                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2645                 TOKEN(ARROW);
2646             }
2647             else if (*s == '$')
2648                 OPERATOR(ARROW);
2649             else
2650                 TERM(ARROW);
2651         }
2652         if (PL_expect == XOPERATOR)
2653             Aop(OP_SUBTRACT);
2654         else {
2655             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2656                 check_uni();
2657             OPERATOR('-');              /* unary minus */
2658         }
2659
2660     case '+':
2661         tmp = *s++;
2662         if (*s == tmp) {
2663             s++;
2664             if (PL_expect == XOPERATOR)
2665                 TERM(POSTINC);
2666             else
2667                 OPERATOR(PREINC);
2668         }
2669         if (PL_expect == XOPERATOR)
2670             Aop(OP_ADD);
2671         else {
2672             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2673                 check_uni();
2674             OPERATOR('+');
2675         }
2676
2677     case '*':
2678         if (PL_expect != XOPERATOR) {
2679             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2680             PL_expect = XOPERATOR;
2681             force_ident(PL_tokenbuf, '*');
2682             if (!*PL_tokenbuf)
2683                 PREREF('*');
2684             TERM('*');
2685         }
2686         s++;
2687         if (*s == '*') {
2688             s++;
2689             PWop(OP_POW);
2690         }
2691         Mop(OP_MULTIPLY);
2692
2693     case '%':
2694         if (PL_expect == XOPERATOR) {
2695             ++s;
2696             Mop(OP_MODULO);
2697         }
2698         PL_tokenbuf[0] = '%';
2699         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2700         if (!PL_tokenbuf[1]) {
2701             if (s == PL_bufend)
2702                 yyerror("Final % should be \\% or %name");
2703             PREREF('%');
2704         }
2705         PL_pending_ident = '%';
2706         TERM('%');
2707
2708     case '^':
2709         s++;
2710         BOop(OP_BIT_XOR);
2711     case '[':
2712         PL_lex_brackets++;
2713         /* FALL THROUGH */
2714     case '~':
2715     case ',':
2716         tmp = *s++;
2717         OPERATOR(tmp);
2718     case ':':
2719         if (s[1] == ':') {
2720             len = 0;
2721             goto just_a_word;
2722         }
2723         s++;
2724         switch (PL_expect) {
2725             OP *attrs;
2726         case XOPERATOR:
2727             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2728                 break;
2729             PL_bufptr = s;      /* update in case we back off */
2730             goto grabattrs;
2731         case XATTRBLOCK:
2732             PL_expect = XBLOCK;
2733             goto grabattrs;
2734         case XATTRTERM:
2735             PL_expect = XTERMBLOCK;
2736          grabattrs:
2737             s = skipspace(s);
2738             attrs = Nullop;
2739             while (isIDFIRST_lazy(s)) {
2740                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2741                 if (*d == '(') {
2742                     d = scan_str(d,TRUE,TRUE);
2743                     if (!d) {
2744                         if (PL_lex_stuff) {
2745                             SvREFCNT_dec(PL_lex_stuff);
2746                             PL_lex_stuff = Nullsv;
2747                         }
2748                         /* MUST advance bufptr here to avoid bogus
2749                            "at end of line" context messages from yyerror().
2750                          */
2751                         PL_bufptr = s + len;
2752                         yyerror("Unterminated attribute parameter in attribute list");
2753                         if (attrs)
2754                             op_free(attrs);
2755                         return 0;       /* EOF indicator */
2756                     }
2757                 }
2758                 if (PL_lex_stuff) {
2759                     SV *sv = newSVpvn(s, len);
2760                     sv_catsv(sv, PL_lex_stuff);
2761                     attrs = append_elem(OP_LIST, attrs,
2762                                         newSVOP(OP_CONST, 0, sv));
2763                     SvREFCNT_dec(PL_lex_stuff);
2764                     PL_lex_stuff = Nullsv;
2765                 }
2766                 else {
2767                     attrs = append_elem(OP_LIST, attrs,
2768                                         newSVOP(OP_CONST, 0,
2769                                                 newSVpvn(s, len)));
2770                 }
2771                 s = skipspace(d);
2772                 while (*s == ',')
2773                     s = skipspace(s+1);
2774             }
2775             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}' for vi */
2776             if (*s != ';' && *s != tmp) {
2777                 char q = ((*s == '\'') ? '"' : '\'');
2778                 /* If here for an expression, and parsed no attrs, back off. */
2779                 if (tmp == '=' && !attrs) {
2780                     s = PL_bufptr;
2781                     break;
2782                 }
2783                 /* MUST advance bufptr here to avoid bogus "at end of line"
2784                    context messages from yyerror().
2785                  */
2786                 PL_bufptr = s;
2787                 if (!*s)
2788                     yyerror("Unterminated attribute list");
2789                 else
2790                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2791                                       q, *s, q));
2792                 if (attrs)
2793                     op_free(attrs);
2794                 OPERATOR(':');
2795             }
2796             if (attrs) {
2797                 PL_nextval[PL_nexttoke].opval = attrs;
2798                 force_next(THING);
2799             }
2800             TOKEN(COLONATTR);
2801         }
2802         OPERATOR(':');
2803     case '(':
2804         s++;
2805         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2806             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
2807         else
2808             PL_expect = XTERM;
2809         TOKEN('(');
2810     case ';':
2811         if (PL_curcop->cop_line < PL_copline)
2812             PL_copline = PL_curcop->cop_line;
2813         tmp = *s++;
2814         OPERATOR(tmp);
2815     case ')':
2816         tmp = *s++;
2817         s = skipspace(s);
2818         if (*s == '{')
2819             PREBLOCK(tmp);
2820         TERM(tmp);
2821     case ']':
2822         s++;
2823         if (PL_lex_brackets <= 0)
2824             yyerror("Unmatched right square bracket");
2825         else
2826             --PL_lex_brackets;
2827         if (PL_lex_state == LEX_INTERPNORMAL) {
2828             if (PL_lex_brackets == 0) {
2829                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2830                     PL_lex_state = LEX_INTERPEND;
2831             }
2832         }
2833         TERM(']');
2834     case '{':
2835       leftbracket:
2836         s++;
2837         if (PL_lex_brackets > 100) {
2838             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2839             if (newlb != PL_lex_brackstack) {
2840                 SAVEFREEPV(newlb);
2841                 PL_lex_brackstack = newlb;
2842             }
2843         }
2844         switch (PL_expect) {
2845         case XTERM:
2846             if (PL_lex_formbrack) {
2847                 s--;
2848                 PRETERMBLOCK(DO);
2849             }
2850             if (PL_oldoldbufptr == PL_last_lop)
2851                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2852             else
2853                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2854             OPERATOR(HASHBRACK);
2855         case XOPERATOR:
2856             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2857                 s++;
2858             d = s;
2859             PL_tokenbuf[0] = '\0';
2860             if (d < PL_bufend && *d == '-') {
2861                 PL_tokenbuf[0] = '-';
2862                 d++;
2863                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2864                     d++;
2865             }
2866             if (d < PL_bufend && isIDFIRST_lazy(d)) {
2867                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2868                               FALSE, &len);
2869                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2870                     d++;
2871                 if (*d == '}') {
2872                     char minus = (PL_tokenbuf[0] == '-');
2873                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2874                     if (minus)
2875                         force_next('-');
2876                 }
2877             }
2878             /* FALL THROUGH */
2879         case XATTRBLOCK:
2880         case XBLOCK:
2881             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2882             PL_expect = XSTATE;
2883             break;
2884         case XATTRTERM:
2885         case XTERMBLOCK:
2886             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2887             PL_expect = XSTATE;
2888             break;
2889         default: {
2890                 char *t;
2891                 if (PL_oldoldbufptr == PL_last_lop)
2892                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2893                 else
2894                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2895                 s = skipspace(s);
2896                 if (*s == '}')
2897                     OPERATOR(HASHBRACK);
2898                 /* This hack serves to disambiguate a pair of curlies
2899                  * as being a block or an anon hash.  Normally, expectation
2900                  * determines that, but in cases where we're not in a
2901                  * position to expect anything in particular (like inside
2902                  * eval"") we have to resolve the ambiguity.  This code
2903                  * covers the case where the first term in the curlies is a
2904                  * quoted string.  Most other cases need to be explicitly
2905                  * disambiguated by prepending a `+' before the opening
2906                  * curly in order to force resolution as an anon hash.
2907                  *
2908                  * XXX should probably propagate the outer expectation
2909                  * into eval"" to rely less on this hack, but that could
2910                  * potentially break current behavior of eval"".
2911                  * GSAR 97-07-21
2912                  */
2913                 t = s;
2914                 if (*s == '\'' || *s == '"' || *s == '`') {
2915                     /* common case: get past first string, handling escapes */
2916                     for (t++; t < PL_bufend && *t != *s;)
2917                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
2918                             t++;
2919                     t++;
2920                 }
2921                 else if (*s == 'q') {
2922                     if (++t < PL_bufend
2923                         && (!isALNUM(*t)
2924                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2925                                 && !isALNUM(*t)))) {
2926                         char *tmps;
2927                         char open, close, term;
2928                         I32 brackets = 1;
2929
2930                         while (t < PL_bufend && isSPACE(*t))
2931                             t++;
2932                         term = *t;
2933                         open = term;
2934                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2935                             term = tmps[5];
2936                         close = term;
2937                         if (open == close)
2938                             for (t++; t < PL_bufend; t++) {
2939                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2940                                     t++;
2941                                 else if (*t == open)
2942                                     break;
2943                             }
2944                         else
2945                             for (t++; t < PL_bufend; t++) {
2946                                 if (*t == '\\' && t+1 < PL_bufend)
2947                                     t++;
2948                                 else if (*t == close && --brackets <= 0)
2949                                     break;
2950                                 else if (*t == open)
2951                                     brackets++;
2952                             }
2953                     }
2954                     t++;
2955                 }
2956                 else if (isIDFIRST_lazy(s)) {
2957                     for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2958                 }
2959                 while (t < PL_bufend && isSPACE(*t))
2960                     t++;
2961                 /* if comma follows first term, call it an anon hash */
2962                 /* XXX it could be a comma expression with loop modifiers */
2963                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2964                                    || (*t == '=' && t[1] == '>')))
2965                     OPERATOR(HASHBRACK);
2966                 if (PL_expect == XREF)
2967                     PL_expect = XTERM;
2968                 else {
2969                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2970                     PL_expect = XSTATE;
2971                 }
2972             }
2973             break;
2974         }
2975         yylval.ival = PL_curcop->cop_line;
2976         if (isSPACE(*s) || *s == '#')
2977             PL_copline = NOLINE;   /* invalidate current command line number */
2978         TOKEN('{');
2979     case '}':
2980       rightbracket:
2981         s++;
2982         if (PL_lex_brackets <= 0)
2983             yyerror("Unmatched right curly bracket");
2984         else
2985             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2986         if (PL_lex_brackets < PL_lex_formbrack)
2987             PL_lex_formbrack = 0;
2988         if (PL_lex_state == LEX_INTERPNORMAL) {
2989             if (PL_lex_brackets == 0) {
2990                 if (PL_lex_fakebrack) {
2991                     PL_lex_state = LEX_INTERPEND;
2992                     PL_bufptr = s;
2993                     return yylex();     /* ignore fake brackets */
2994                 }
2995                 if (*s == '-' && s[1] == '>')
2996                     PL_lex_state = LEX_INTERPENDMAYBE;
2997                 else if (*s != '[' && *s != '{')
2998                     PL_lex_state = LEX_INTERPEND;
2999             }
3000         }
3001         if (PL_lex_brackets < PL_lex_fakebrack) {
3002             PL_bufptr = s;
3003             PL_lex_fakebrack = 0;
3004             return yylex();             /* ignore fake brackets */
3005         }
3006         force_next('}');
3007         TOKEN(';');
3008     case '&':
3009         s++;
3010         tmp = *s++;
3011         if (tmp == '&')
3012             AOPERATOR(ANDAND);
3013         s--;
3014         if (PL_expect == XOPERATOR) {
3015             if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
3016                 PL_curcop->cop_line--;
3017                 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3018                 PL_curcop->cop_line++;
3019             }
3020             BAop(OP_BIT_AND);
3021         }
3022
3023         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3024         if (*PL_tokenbuf) {
3025             PL_expect = XOPERATOR;
3026             force_ident(PL_tokenbuf, '&');
3027         }
3028         else
3029             PREREF('&');
3030         yylval.ival = (OPpENTERSUB_AMPER<<8);
3031         TERM('&');
3032
3033     case '|':
3034         s++;
3035         tmp = *s++;
3036         if (tmp == '|')
3037             AOPERATOR(OROR);
3038         s--;
3039         BOop(OP_BIT_OR);
3040     case '=':
3041         s++;
3042         tmp = *s++;
3043         if (tmp == '=')
3044             Eop(OP_EQ);
3045         if (tmp == '>')
3046             OPERATOR(',');
3047         if (tmp == '~')
3048             PMop(OP_MATCH);
3049         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3050             Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3051         s--;
3052         if (PL_expect == XSTATE && isALPHA(tmp) &&
3053                 (s == PL_linestart+1 || s[-2] == '\n') )
3054         {
3055             if (PL_in_eval && !PL_rsfp) {
3056                 d = PL_bufend;
3057                 while (s < d) {
3058                     if (*s++ == '\n') {
3059                         incline(s);
3060                         if (strnEQ(s,"=cut",4)) {
3061                             s = strchr(s,'\n');
3062                             if (s)
3063                                 s++;
3064                             else
3065                                 s = d;
3066                             incline(s);
3067                             goto retry;
3068                         }
3069                     }
3070                 }
3071                 goto retry;
3072             }
3073             s = PL_bufend;
3074             PL_doextract = TRUE;
3075             goto retry;
3076         }
3077         if (PL_lex_brackets < PL_lex_formbrack) {
3078             char *t;
3079 #ifdef PERL_STRICT_CR
3080             for (t = s; *t == ' ' || *t == '\t'; t++) ;
3081 #else
3082             for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3083 #endif
3084             if (*t == '\n' || *t == '#') {
3085                 s--;
3086                 PL_expect = XBLOCK;
3087                 goto leftbracket;
3088             }
3089         }
3090         yylval.ival = 0;
3091         OPERATOR(ASSIGNOP);
3092     case '!':
3093         s++;
3094         tmp = *s++;
3095         if (tmp == '=')
3096             Eop(OP_NE);
3097         if (tmp == '~')
3098             PMop(OP_NOT);
3099         s--;
3100         OPERATOR('!');
3101     case '<':
3102         if (PL_expect != XOPERATOR) {
3103             if (s[1] != '<' && !strchr(s,'>'))
3104                 check_uni();
3105             if (s[1] == '<')
3106                 s = scan_heredoc(s);
3107             else
3108                 s = scan_inputsymbol(s);
3109             TERM(sublex_start());
3110         }
3111         s++;
3112         tmp = *s++;
3113         if (tmp == '<')
3114             SHop(OP_LEFT_SHIFT);
3115         if (tmp == '=') {
3116             tmp = *s++;
3117             if (tmp == '>')
3118                 Eop(OP_NCMP);
3119             s--;
3120             Rop(OP_LE);
3121         }
3122         s--;
3123         Rop(OP_LT);
3124     case '>':
3125         s++;
3126         tmp = *s++;
3127         if (tmp == '>')
3128             SHop(OP_RIGHT_SHIFT);
3129         if (tmp == '=')
3130             Rop(OP_GE);
3131         s--;
3132         Rop(OP_GT);
3133
3134     case '$':
3135         CLINE;
3136
3137         if (PL_expect == XOPERATOR) {
3138             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3139                 PL_expect = XTERM;
3140                 depcom();
3141                 return ','; /* grandfather non-comma-format format */
3142             }
3143         }
3144
3145         if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
3146             PL_tokenbuf[0] = '@';
3147             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3148                            sizeof PL_tokenbuf - 1, FALSE);
3149             if (PL_expect == XOPERATOR)
3150                 no_op("Array length", s);
3151             if (!PL_tokenbuf[1])
3152                 PREREF(DOLSHARP);
3153             PL_expect = XOPERATOR;
3154             PL_pending_ident = '#';
3155             TOKEN(DOLSHARP);
3156         }
3157
3158         PL_tokenbuf[0] = '$';
3159         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3160                        sizeof PL_tokenbuf - 1, FALSE);
3161         if (PL_expect == XOPERATOR)
3162             no_op("Scalar", s);
3163         if (!PL_tokenbuf[1]) {
3164             if (s == PL_bufend)
3165                 yyerror("Final $ should be \\$ or $name");
3166             PREREF('$');
3167         }
3168
3169         /* This kludge not intended to be bulletproof. */
3170         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3171             yylval.opval = newSVOP(OP_CONST, 0,
3172                                    newSViv((IV)PL_compiling.cop_arybase));
3173             yylval.opval->op_private = OPpCONST_ARYBASE;
3174             TERM(THING);
3175         }
3176
3177         d = s;
3178         tmp = (I32)*s;
3179         if (PL_lex_state == LEX_NORMAL)
3180             s = skipspace(s);
3181
3182         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3183             char *t;
3184             if (*s == '[') {
3185                 PL_tokenbuf[0] = '@';
3186                 if (ckWARN(WARN_SYNTAX)) {
3187                     for(t = s + 1;
3188                         isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
3189                         t++) ;
3190                     if (*t++ == ',') {
3191                         PL_bufptr = skipspace(PL_bufptr);
3192                         while (t < PL_bufend && *t != ']')
3193                             t++;
3194                         Perl_warner(aTHX_ WARN_SYNTAX,
3195                                 "Multidimensional syntax %.*s not supported",
3196                                 (t - PL_bufptr) + 1, PL_bufptr);
3197                     }
3198                 }
3199             }
3200             else if (*s == '{') {
3201                 PL_tokenbuf[0] = '%';
3202                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3203                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3204                 {
3205                     char tmpbuf[sizeof PL_tokenbuf];
3206                     STRLEN len;
3207                     for (t++; isSPACE(*t); t++) ;
3208                     if (isIDFIRST_lazy(t)) {
3209                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3210                         for (; isSPACE(*t); t++) ;
3211                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3212                             Perl_warner(aTHX_ WARN_SYNTAX,
3213                                 "You need to quote \"%s\"", tmpbuf);
3214                     }
3215                 }
3216             }
3217         }
3218
3219         PL_expect = XOPERATOR;
3220         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3221             bool islop = (PL_last_lop == PL_oldoldbufptr);
3222             if (!islop || PL_last_lop_op == OP_GREPSTART)
3223                 PL_expect = XOPERATOR;
3224             else if (strchr("$@\"'`q", *s))
3225                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3226             else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
3227                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3228             else if (isIDFIRST_lazy(s)) {
3229                 char tmpbuf[sizeof PL_tokenbuf];
3230                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3231                 if (tmp = keyword(tmpbuf, len)) {
3232                     /* binary operators exclude handle interpretations */
3233                     switch (tmp) {
3234                     case -KEY_x:
3235                     case -KEY_eq:
3236                     case -KEY_ne:
3237                     case -KEY_gt:
3238                     case -KEY_lt:
3239                     case -KEY_ge:
3240                     case -KEY_le:
3241                     case -KEY_cmp:
3242                         break;
3243                     default:
3244                         PL_expect = XTERM;      /* e.g. print $fh length() */
3245                         break;
3246                     }
3247                 }
3248                 else {
3249                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3250                     if (gv && GvCVu(gv))
3251                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3252                 }
3253             }
3254             else if (isDIGIT(*s))
3255                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3256             else if (*s == '.' && isDIGIT(s[1]))
3257                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3258             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3259                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3260             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3261                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3262         }
3263         PL_pending_ident = '$';
3264         TOKEN('$');
3265
3266     case '@':
3267         if (PL_expect == XOPERATOR)
3268             no_op("Array", s);
3269         PL_tokenbuf[0] = '@';
3270         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3271         if (!PL_tokenbuf[1]) {
3272             if (s == PL_bufend)
3273                 yyerror("Final @ should be \\@ or @name");
3274             PREREF('@');
3275         }
3276         if (PL_lex_state == LEX_NORMAL)
3277             s = skipspace(s);
3278         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3279             if (*s == '{')
3280                 PL_tokenbuf[0] = '%';
3281
3282             /* Warn about @ where they meant $. */
3283             if (ckWARN(WARN_SYNTAX)) {
3284                 if (*s == '[' || *s == '{') {
3285                     char *t = s + 1;
3286                     while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
3287                         t++;
3288                     if (*t == '}' || *t == ']') {
3289                         t++;
3290                         PL_bufptr = skipspace(PL_bufptr);
3291                         Perl_warner(aTHX_ WARN_SYNTAX,
3292                             "Scalar value %.*s better written as $%.*s",
3293                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3294                     }
3295                 }
3296             }
3297         }
3298         PL_pending_ident = '@';
3299         TERM('@');
3300
3301     case '/':                   /* may either be division or pattern */
3302     case '?':                   /* may either be conditional or pattern */
3303         if (PL_expect != XOPERATOR) {
3304             /* Disable warning on "study /blah/" */
3305             if (PL_oldoldbufptr == PL_last_uni
3306                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3307                     || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
3308                 check_uni();
3309             s = scan_pat(s,OP_MATCH);
3310             TERM(sublex_start());
3311         }
3312         tmp = *s++;
3313         if (tmp == '/')
3314             Mop(OP_DIVIDE);
3315         OPERATOR(tmp);
3316
3317     case '.':
3318         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3319 #ifdef PERL_STRICT_CR
3320             && s[1] == '\n'
3321 #else
3322             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3323 #endif
3324             && (s == PL_linestart || s[-1] == '\n') )
3325         {
3326             PL_lex_formbrack = 0;
3327             PL_expect = XSTATE;
3328             goto rightbracket;
3329         }
3330         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3331             tmp = *s++;
3332             if (*s == tmp) {
3333                 s++;
3334                 if (*s == tmp) {
3335                     s++;
3336                     yylval.ival = OPf_SPECIAL;
3337                 }
3338                 else
3339                     yylval.ival = 0;
3340                 OPERATOR(DOTDOT);
3341             }
3342             if (PL_expect != XOPERATOR)
3343                 check_uni();
3344             Aop(OP_CONCAT);
3345         }
3346         /* FALL THROUGH */
3347     case '0': case '1': case '2': case '3': case '4':
3348     case '5': case '6': case '7': case '8': case '9':
3349         s = scan_num(s);
3350         if (PL_expect == XOPERATOR)
3351             no_op("Number",s);
3352         TERM(THING);
3353
3354     case '\'':
3355         s = scan_str(s,FALSE,FALSE);
3356         if (PL_expect == XOPERATOR) {
3357             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3358                 PL_expect = XTERM;
3359                 depcom();
3360                 return ',';     /* grandfather non-comma-format format */
3361             }
3362             else
3363                 no_op("String",s);
3364         }
3365         if (!s)
3366             missingterm((char*)0);
3367         yylval.ival = OP_CONST;
3368         TERM(sublex_start());
3369
3370     case '"':
3371         s = scan_str(s,FALSE,FALSE);
3372         if (PL_expect == XOPERATOR) {
3373             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3374                 PL_expect = XTERM;
3375                 depcom();
3376                 return ',';     /* grandfather non-comma-format format */
3377             }
3378             else
3379                 no_op("String",s);
3380         }
3381         if (!s)
3382             missingterm((char*)0);
3383         yylval.ival = OP_CONST;
3384         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3385             if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3386                 yylval.ival = OP_STRINGIFY;
3387                 break;
3388             }
3389         }
3390         TERM(sublex_start());
3391
3392     case '`':
3393         s = scan_str(s,FALSE,FALSE);
3394         if (PL_expect == XOPERATOR)
3395             no_op("Backticks",s);
3396         if (!s)
3397             missingterm((char*)0);
3398         yylval.ival = OP_BACKTICK;
3399         set_csh();
3400         TERM(sublex_start());
3401
3402     case '\\':
3403         s++;
3404         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3405             Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3406                         *s, *s);
3407         if (PL_expect == XOPERATOR)
3408             no_op("Backslash",s);
3409         OPERATOR(REFGEN);
3410
3411     case 'x':
3412         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3413             s++;
3414             Mop(OP_REPEAT);
3415         }
3416         goto keylookup;
3417
3418     case '_':
3419     case 'a': case 'A':
3420     case 'b': case 'B':
3421     case 'c': case 'C':
3422     case 'd': case 'D':
3423     case 'e': case 'E':
3424     case 'f': case 'F':
3425     case 'g': case 'G':
3426     case 'h': case 'H':
3427     case 'i': case 'I':
3428     case 'j': case 'J':
3429     case 'k': case 'K':
3430     case 'l': case 'L':
3431     case 'm': case 'M':
3432     case 'n': case 'N':
3433     case 'o': case 'O':
3434     case 'p': case 'P':
3435     case 'q': case 'Q':
3436     case 'r': case 'R':
3437     case 's': case 'S':
3438     case 't': case 'T':
3439     case 'u': case 'U':
3440     case 'v': case 'V':
3441     case 'w': case 'W':
3442               case 'X':
3443     case 'y': case 'Y':
3444     case 'z': case 'Z':
3445
3446       keylookup: {
3447         STRLEN n_a;
3448         gv = Nullgv;
3449         gvp = 0;
3450
3451         PL_bufptr = s;
3452         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3453
3454         /* Some keywords can be followed by any delimiter, including ':' */
3455         tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3456                len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3457                             (PL_tokenbuf[0] == 'q' &&
3458                              strchr("qwxr", PL_tokenbuf[1]))));
3459
3460         /* x::* is just a word, unless x is "CORE" */
3461         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3462             goto just_a_word;
3463
3464         d = s;
3465         while (d < PL_bufend && isSPACE(*d))
3466                 d++;    /* no comments skipped here, or s### is misparsed */
3467
3468         /* Is this a label? */
3469         if (!tmp && PL_expect == XSTATE
3470               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3471             s = d + 1;
3472             yylval.pval = savepv(PL_tokenbuf);
3473             CLINE;
3474             TOKEN(LABEL);
3475         }
3476
3477         /* Check for keywords */
3478         tmp = keyword(PL_tokenbuf, len);
3479
3480         /* Is this a word before a => operator? */
3481         if (strnEQ(d,"=>",2)) {
3482             CLINE;
3483             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3484             yylval.opval->op_private = OPpCONST_BARE;
3485             TERM(WORD);
3486         }
3487
3488         if (tmp < 0) {                  /* second-class keyword? */
3489             GV *ogv = Nullgv;   /* override (winner) */
3490             GV *hgv = Nullgv;   /* hidden (loser) */
3491             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3492                 CV *cv;
3493                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3494                     (cv = GvCVu(gv)))
3495                 {
3496                     if (GvIMPORTED_CV(gv))
3497                         ogv = gv;
3498                     else if (! CvMETHOD(cv))
3499                         hgv = gv;
3500                 }
3501                 if (!ogv &&
3502                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3503                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3504                     GvCVu(gv) && GvIMPORTED_CV(gv))
3505                 {
3506                     ogv = gv;
3507                 }
3508             }
3509             if (ogv) {
3510                 tmp = 0;                /* overridden by import or by GLOBAL */
3511             }
3512             else if (gv && !gvp
3513                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3514                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3515             {
3516                 tmp = 0;                /* any sub overrides "weak" keyword */
3517             }
3518             else {                      /* no override */
3519                 tmp = -tmp;
3520                 gv = Nullgv;
3521                 gvp = 0;
3522                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3523                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3524                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3525                         "Ambiguous call resolved as CORE::%s(), %s",
3526                          GvENAME(hgv), "qualify as such or use &");
3527             }
3528         }
3529
3530       reserved_word:
3531         switch (tmp) {
3532
3533         default:                        /* not a keyword */
3534           just_a_word: {
3535                 SV *sv;
3536                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3537
3538                 /* Get the rest if it looks like a package qualifier */
3539
3540                 if (*s == '\'' || *s == ':' && s[1] == ':') {
3541                     STRLEN morelen;
3542                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3543                                   TRUE, &morelen);
3544                     if (!morelen)
3545                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3546                                 *s == '\'' ? "'" : "::");
3547                     len += morelen;
3548                 }
3549
3550                 if (PL_expect == XOPERATOR) {
3551                     if (PL_bufptr == PL_linestart) {
3552                         PL_curcop->cop_line--;
3553                         Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3554                         PL_curcop->cop_line++;
3555                     }
3556                     else
3557                         no_op("Bareword",s);
3558                 }
3559
3560                 /* Look for a subroutine with this name in current package,
3561                    unless name is "Foo::", in which case Foo is a bearword
3562                    (and a package name). */
3563
3564                 if (len > 2 &&
3565                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3566                 {
3567                     if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3568                         Perl_warner(aTHX_ WARN_UNSAFE,
3569                             "Bareword \"%s\" refers to nonexistent package",
3570                              PL_tokenbuf);
3571                     len -= 2;
3572                     PL_tokenbuf[len] = '\0';
3573                     gv = Nullgv;
3574                     gvp = 0;
3575                 }
3576                 else {
3577                     len = 0;
3578                     if (!gv)
3579                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3580                 }
3581
3582                 /* if we saw a global override before, get the right name */
3583
3584                 if (gvp) {
3585                     sv = newSVpvn("CORE::GLOBAL::",14);
3586                     sv_catpv(sv,PL_tokenbuf);
3587                 }
3588                 else
3589                     sv = newSVpv(PL_tokenbuf,0);
3590
3591                 /* Presume this is going to be a bareword of some sort. */
3592
3593                 CLINE;
3594                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3595                 yylval.opval->op_private = OPpCONST_BARE;
3596
3597                 /* And if "Foo::", then that's what it certainly is. */
3598
3599                 if (len)
3600                     goto safe_bareword;
3601
3602                 /* See if it's the indirect object for a list operator. */
3603
3604                 if (PL_oldoldbufptr &&
3605                     PL_oldoldbufptr < PL_bufptr &&
3606                     (PL_oldoldbufptr == PL_last_lop
3607                      || PL_oldoldbufptr == PL_last_uni) &&
3608                     /* NO SKIPSPACE BEFORE HERE! */
3609                     (PL_expect == XREF ||
3610                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3611                 {
3612                     bool immediate_paren = *s == '(';
3613
3614                     /* (Now we can afford to cross potential line boundary.) */
3615                     s = skipspace(s);
3616
3617                     /* Two barewords in a row may indicate method call. */
3618
3619                     if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3620                         return tmp;
3621
3622                     /* If not a declared subroutine, it's an indirect object. */
3623                     /* (But it's an indir obj regardless for sort.) */
3624
3625                     if ((PL_last_lop_op == OP_SORT ||
3626                          (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3627                         (PL_last_lop_op != OP_MAPSTART &&
3628                          PL_last_lop_op != OP_GREPSTART))
3629                     {
3630                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3631                         goto bareword;
3632                     }
3633                 }
3634
3635                 /* If followed by a paren, it's certainly a subroutine. */
3636
3637                 PL_expect = XOPERATOR;
3638                 s = skipspace(s);
3639                 if (*s == '(') {
3640                     CLINE;
3641                     if (gv && GvCVu(gv)) {
3642                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3643                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3644                             s = d + 1;
3645                             goto its_constant;
3646                         }
3647                     }
3648                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3649                     PL_expect = XOPERATOR;
3650                     force_next(WORD);
3651                     yylval.ival = 0;
3652                     TOKEN('&');
3653                 }
3654
3655                 /* If followed by var or block, call it a method (unless sub) */
3656
3657                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3658                     PL_last_lop = PL_oldbufptr;
3659                     PL_last_lop_op = OP_METHOD;
3660                     PREBLOCK(METHOD);
3661                 }
3662
3663                 /* If followed by a bareword, see if it looks like indir obj. */
3664
3665                 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3666                     return tmp;
3667
3668                 /* Not a method, so call it a subroutine (if defined) */
3669
3670                 if (gv && GvCVu(gv)) {
3671                     CV* cv;
3672                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3673                         Perl_warner(aTHX_ WARN_AMBIGUOUS,
3674                                 "Ambiguous use of -%s resolved as -&%s()",
3675                                 PL_tokenbuf, PL_tokenbuf);
3676                     /* Check for a constant sub */
3677                     cv = GvCV(gv);
3678                     if ((sv = cv_const_sv(cv))) {
3679                   its_constant:
3680                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3681                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3682                         yylval.opval->op_private = 0;
3683                         TOKEN(WORD);
3684                     }
3685
3686                     /* Resolve to GV now. */
3687                     op_free(yylval.opval);
3688                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3689                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3690                     PL_last_lop = PL_oldbufptr;
3691                     PL_last_lop_op = OP_ENTERSUB;
3692                     /* Is there a prototype? */
3693                     if (SvPOK(cv)) {
3694                         STRLEN len;
3695                         char *proto = SvPV((SV*)cv, len);
3696                         if (!len)
3697                             TERM(FUNC0SUB);
3698                         if (strEQ(proto, "$"))
3699                             OPERATOR(UNIOPSUB);
3700                         if (*proto == '&' && *s == '{') {
3701                             sv_setpv(PL_subname,"__ANON__");
3702                             PREBLOCK(LSTOPSUB);
3703                         }
3704                     }
3705                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3706                     PL_expect = XTERM;
3707                     force_next(WORD);
3708                     TOKEN(NOAMP);
3709                 }
3710
3711                 /* Call it a bare word */
3712
3713                 if (PL_hints & HINT_STRICT_SUBS)
3714                     yylval.opval->op_private |= OPpCONST_STRICT;
3715                 else {
3716                 bareword:
3717                     if (ckWARN(WARN_RESERVED)) {
3718                         if (lastchar != '-') {
3719                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3720                             if (!*d)
3721                                 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3722                                        PL_tokenbuf);
3723                         }
3724                     }
3725                 }
3726
3727             safe_bareword:
3728                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3729                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3730                         "Operator or semicolon missing before %c%s",
3731                         lastchar, PL_tokenbuf);
3732                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3733                         "Ambiguous use of %c resolved as operator %c",
3734                         lastchar, lastchar);
3735                 }
3736                 TOKEN(WORD);
3737             }
3738
3739         case KEY___FILE__:
3740             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3741                                         newSVsv(GvSV(PL_curcop->cop_filegv)));
3742             TERM(THING);
3743
3744         case KEY___LINE__:
3745 #ifdef IV_IS_QUAD
3746             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3747                                     Perl_newSVpvf(aTHX_ "%" PERL_PRId64, (IV)PL_curcop->cop_line));
3748 #else
3749             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3750                                     Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3751 #endif
3752             TERM(THING);
3753
3754         case KEY___PACKAGE__:
3755             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3756                                         (PL_curstash
3757                                          ? newSVsv(PL_curstname)
3758                                          : &PL_sv_undef));
3759             TERM(THING);
3760
3761         case KEY___DATA__:
3762         case KEY___END__: {
3763             GV *gv;
3764
3765             /*SUPPRESS 560*/
3766             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3767                 char *pname = "main";
3768                 if (PL_tokenbuf[2] == 'D')
3769                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3770                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3771                 GvMULTI_on(gv);
3772                 if (!GvIO(gv))
3773                     GvIOp(gv) = newIO();
3774                 IoIFP(GvIOp(gv)) = PL_rsfp;
3775 #if defined(HAS_FCNTL) && defined(F_SETFD)
3776                 {
3777                     int fd = PerlIO_fileno(PL_rsfp);
3778                     fcntl(fd,F_SETFD,fd >= 3);
3779                 }
3780 #endif
3781                 /* Mark this internal pseudo-handle as clean */
3782                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3783                 if (PL_preprocess)
3784                     IoTYPE(GvIOp(gv)) = '|';
3785                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3786                     IoTYPE(GvIOp(gv)) = '-';
3787                 else
3788                     IoTYPE(GvIOp(gv)) = '<';
3789                 PL_rsfp = Nullfp;
3790             }
3791             goto fake_eof;
3792         }
3793
3794         case KEY_AUTOLOAD:
3795         case KEY_DESTROY:
3796         case KEY_BEGIN:
3797         case KEY_END:
3798         case KEY_INIT:
3799             if (PL_expect == XSTATE) {
3800                 s = PL_bufptr;
3801                 goto really_sub;
3802             }
3803             goto just_a_word;
3804
3805         case KEY_CORE:
3806             if (*s == ':' && s[1] == ':') {
3807                 s += 2;
3808                 d = s;
3809                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3810                 tmp = keyword(PL_tokenbuf, len);
3811                 if (tmp < 0)
3812                     tmp = -tmp;
3813                 goto reserved_word;
3814             }
3815             goto just_a_word;
3816
3817         case KEY_abs:
3818             UNI(OP_ABS);
3819
3820         case KEY_alarm:
3821             UNI(OP_ALARM);
3822
3823         case KEY_accept:
3824             LOP(OP_ACCEPT,XTERM);
3825
3826         case KEY_and:
3827             OPERATOR(ANDOP);
3828
3829         case KEY_atan2:
3830             LOP(OP_ATAN2,XTERM);
3831
3832         case KEY_bind:
3833             LOP(OP_BIND,XTERM);
3834
3835         case KEY_binmode:
3836             UNI(OP_BINMODE);
3837
3838         case KEY_bless:
3839             LOP(OP_BLESS,XTERM);
3840
3841         case KEY_chop:
3842             UNI(OP_CHOP);
3843
3844         case KEY_continue:
3845             PREBLOCK(CONTINUE);
3846
3847         case KEY_chdir:
3848             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3849             UNI(OP_CHDIR);
3850
3851         case KEY_close:
3852             UNI(OP_CLOSE);
3853
3854         case KEY_closedir:
3855             UNI(OP_CLOSEDIR);
3856
3857         case KEY_cmp:
3858             Eop(OP_SCMP);
3859
3860         case KEY_caller:
3861             UNI(OP_CALLER);
3862
3863         case KEY_crypt:
3864 #ifdef FCRYPT
3865             if (!PL_cryptseen++)
3866                 init_des();
3867 #endif
3868             LOP(OP_CRYPT,XTERM);
3869
3870         case KEY_chmod:
3871             if (ckWARN(WARN_OCTAL)) {
3872                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3873                 if (*d != '0' && isDIGIT(*d))
3874                     Perl_warner(aTHX_ WARN_OCTAL,
3875                                 "chmod: mode argument is missing initial 0");
3876             }
3877             LOP(OP_CHMOD,XTERM);
3878
3879         case KEY_chown:
3880             LOP(OP_CHOWN,XTERM);
3881
3882         case KEY_connect:
3883             LOP(OP_CONNECT,XTERM);
3884
3885         case KEY_chr:
3886             UNI(OP_CHR);
3887
3888         case KEY_cos:
3889             UNI(OP_COS);
3890
3891         case KEY_chroot:
3892             UNI(OP_CHROOT);
3893
3894         case KEY_do:
3895             s = skipspace(s);
3896             if (*s == '{')
3897                 PRETERMBLOCK(DO);
3898             if (*s != '\'')
3899                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3900             OPERATOR(DO);
3901
3902         case KEY_die:
3903             PL_hints |= HINT_BLOCK_SCOPE;
3904             LOP(OP_DIE,XTERM);
3905
3906         case KEY_defined:
3907             UNI(OP_DEFINED);
3908
3909         case KEY_delete:
3910             UNI(OP_DELETE);
3911
3912         case KEY_dbmopen:
3913             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3914             LOP(OP_DBMOPEN,XTERM);
3915
3916         case KEY_dbmclose:
3917             UNI(OP_DBMCLOSE);
3918
3919         case KEY_dump:
3920             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3921             LOOPX(OP_DUMP);
3922
3923         case KEY_else:
3924             PREBLOCK(ELSE);
3925
3926         case KEY_elsif:
3927             yylval.ival = PL_curcop->cop_line;
3928             OPERATOR(ELSIF);
3929
3930         case KEY_eq:
3931             Eop(OP_SEQ);
3932
3933         case KEY_exists:
3934             UNI(OP_EXISTS);
3935
3936         case KEY_exit:
3937             UNI(OP_EXIT);
3938
3939         case KEY_eval:
3940             s = skipspace(s);
3941             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3942             UNIBRACK(OP_ENTEREVAL);
3943
3944         case KEY_eof:
3945             UNI(OP_EOF);
3946
3947         case KEY_exp:
3948             UNI(OP_EXP);
3949
3950         case KEY_each:
3951             UNI(OP_EACH);
3952
3953         case KEY_exec:
3954             set_csh();
3955             LOP(OP_EXEC,XREF);
3956
3957         case KEY_endhostent:
3958             FUN0(OP_EHOSTENT);
3959
3960         case KEY_endnetent:
3961             FUN0(OP_ENETENT);
3962
3963         case KEY_endservent:
3964             FUN0(OP_ESERVENT);
3965
3966         case KEY_endprotoent:
3967             FUN0(OP_EPROTOENT);
3968
3969         case KEY_endpwent:
3970             FUN0(OP_EPWENT);
3971
3972         case KEY_endgrent:
3973             FUN0(OP_EGRENT);
3974
3975         case KEY_for:
3976         case KEY_foreach:
3977             yylval.ival = PL_curcop->cop_line;
3978             s = skipspace(s);
3979             if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3980                 char *p = s;
3981                 if ((PL_bufend - p) >= 3 &&
3982                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3983                     p += 2;
3984                 else if ((PL_bufend - p) >= 4 &&
3985                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
3986                     p += 3;
3987                 p = skipspace(p);
3988                 if (isIDFIRST_lazy(p)) {
3989                     p = scan_ident(p, PL_bufend,
3990                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3991                     p = skipspace(p);
3992                 }
3993                 if (*p != '$')
3994                     Perl_croak(aTHX_ "Missing $ on loop variable");
3995             }
3996             OPERATOR(FOR);
3997
3998         case KEY_formline:
3999             LOP(OP_FORMLINE,XTERM);
4000
4001         case KEY_fork:
4002             FUN0(OP_FORK);
4003
4004         case KEY_fcntl:
4005             LOP(OP_FCNTL,XTERM);
4006
4007         case KEY_fileno:
4008             UNI(OP_FILENO);
4009
4010         case KEY_flock:
4011             LOP(OP_FLOCK,XTERM);
4012
4013         case KEY_gt:
4014             Rop(OP_SGT);
4015
4016         case KEY_ge:
4017             Rop(OP_SGE);
4018
4019         case KEY_grep:
4020             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
4021
4022         case KEY_goto:
4023             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4024             LOOPX(OP_GOTO);
4025
4026         case KEY_gmtime:
4027             UNI(OP_GMTIME);
4028
4029         case KEY_getc:
4030             UNI(OP_GETC);
4031
4032         case KEY_getppid:
4033             FUN0(OP_GETPPID);
4034
4035         case KEY_getpgrp:
4036             UNI(OP_GETPGRP);
4037
4038         case KEY_getpriority:
4039             LOP(OP_GETPRIORITY,XTERM);
4040
4041         case KEY_getprotobyname:
4042             UNI(OP_GPBYNAME);
4043
4044         case KEY_getprotobynumber:
4045             LOP(OP_GPBYNUMBER,XTERM);
4046
4047         case KEY_getprotoent:
4048             FUN0(OP_GPROTOENT);
4049
4050         case KEY_getpwent:
4051             FUN0(OP_GPWENT);
4052
4053         case KEY_getpwnam:
4054             UNI(OP_GPWNAM);
4055
4056         case KEY_getpwuid:
4057             UNI(OP_GPWUID);
4058
4059         case KEY_getpeername:
4060             UNI(OP_GETPEERNAME);
4061
4062         case KEY_gethostbyname:
4063             UNI(OP_GHBYNAME);
4064
4065         case KEY_gethostbyaddr:
4066             LOP(OP_GHBYADDR,XTERM);
4067
4068         case KEY_gethostent:
4069             FUN0(OP_GHOSTENT);
4070
4071         case KEY_getnetbyname:
4072             UNI(OP_GNBYNAME);
4073
4074         case KEY_getnetbyaddr:
4075             LOP(OP_GNBYADDR,XTERM);
4076
4077         case KEY_getnetent:
4078             FUN0(OP_GNETENT);
4079
4080         case KEY_getservbyname:
4081             LOP(OP_GSBYNAME,XTERM);
4082
4083         case KEY_getservbyport:
4084             LOP(OP_GSBYPORT,XTERM);
4085
4086         case KEY_getservent:
4087             FUN0(OP_GSERVENT);
4088
4089         case KEY_getsockname:
4090             UNI(OP_GETSOCKNAME);
4091
4092         case KEY_getsockopt:
4093             LOP(OP_GSOCKOPT,XTERM);
4094
4095         case KEY_getgrent:
4096             FUN0(OP_GGRENT);
4097
4098         case KEY_getgrnam:
4099             UNI(OP_GGRNAM);
4100
4101         case KEY_getgrgid:
4102             UNI(OP_GGRGID);
4103
4104         case KEY_getlogin:
4105             FUN0(OP_GETLOGIN);
4106
4107         case KEY_glob:
4108             set_csh();
4109             LOP(OP_GLOB,XTERM);
4110
4111         case KEY_hex:
4112             UNI(OP_HEX);
4113
4114         case KEY_if:
4115             yylval.ival = PL_curcop->cop_line;
4116             OPERATOR(IF);
4117
4118         case KEY_index:
4119             LOP(OP_INDEX,XTERM);
4120
4121         case KEY_int:
4122             UNI(OP_INT);
4123
4124         case KEY_ioctl:
4125             LOP(OP_IOCTL,XTERM);
4126
4127         case KEY_join:
4128             LOP(OP_JOIN,XTERM);
4129
4130         case KEY_keys:
4131             UNI(OP_KEYS);
4132
4133         case KEY_kill:
4134             LOP(OP_KILL,XTERM);
4135
4136         case KEY_last:
4137             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4138             LOOPX(OP_LAST);
4139
4140         case KEY_lc:
4141             UNI(OP_LC);
4142
4143         case KEY_lcfirst:
4144             UNI(OP_LCFIRST);
4145
4146         case KEY_local:
4147             yylval.ival = 0;
4148             OPERATOR(LOCAL);
4149
4150         case KEY_length:
4151             UNI(OP_LENGTH);
4152
4153         case KEY_lt:
4154             Rop(OP_SLT);
4155
4156         case KEY_le:
4157             Rop(OP_SLE);
4158
4159         case KEY_localtime:
4160             UNI(OP_LOCALTIME);
4161
4162         case KEY_log:
4163             UNI(OP_LOG);
4164
4165         case KEY_link:
4166             LOP(OP_LINK,XTERM);
4167
4168         case KEY_listen:
4169             LOP(OP_LISTEN,XTERM);
4170
4171         case KEY_lock:
4172             UNI(OP_LOCK);
4173
4174         case KEY_lstat:
4175             UNI(OP_LSTAT);
4176
4177         case KEY_m:
4178             s = scan_pat(s,OP_MATCH);
4179             TERM(sublex_start());
4180
4181         case KEY_map:
4182             LOP(OP_MAPSTART, *s == '(' ? XTERM : XREF);
4183
4184         case KEY_mkdir:
4185             LOP(OP_MKDIR,XTERM);
4186
4187         case KEY_msgctl:
4188             LOP(OP_MSGCTL,XTERM);
4189
4190         case KEY_msgget:
4191             LOP(OP_MSGGET,XTERM);
4192
4193         case KEY_msgrcv:
4194             LOP(OP_MSGRCV,XTERM);
4195
4196         case KEY_msgsnd:
4197             LOP(OP_MSGSND,XTERM);
4198
4199         case KEY_our:
4200         case KEY_my:
4201             PL_in_my = tmp;
4202             s = skipspace(s);
4203             if (isIDFIRST_lazy(s)) {
4204                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4205                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4206                     goto really_sub;
4207                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4208                 if (!PL_in_my_stash) {
4209                     char tmpbuf[1024];
4210                     PL_bufptr = s;
4211                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4212                     yyerror(tmpbuf);
4213                 }
4214             }
4215             yylval.ival = 1;
4216             OPERATOR(MY);
4217
4218         case KEY_next:
4219             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4220             LOOPX(OP_NEXT);
4221
4222         case KEY_ne:
4223             Eop(OP_SNE);
4224
4225         case KEY_no:
4226             if (PL_expect != XSTATE)
4227                 yyerror("\"no\" not allowed in expression");
4228             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4229             s = force_version(s);
4230             yylval.ival = 0;
4231             OPERATOR(USE);
4232
4233         case KEY_not:
4234             OPERATOR(NOTOP);
4235
4236         case KEY_open:
4237             s = skipspace(s);
4238             if (isIDFIRST_lazy(s)) {
4239                 char *t;
4240                 for (d = s; isALNUM_lazy(d); d++) ;
4241                 t = skipspace(d);
4242                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4243                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4244                            "Precedence problem: open %.*s should be open(%.*s)",
4245                             d-s,s, d-s,s);
4246             }
4247             LOP(OP_OPEN,XTERM);
4248
4249         case KEY_or:
4250             yylval.ival = OP_OR;
4251             OPERATOR(OROP);
4252
4253         case KEY_ord:
4254             UNI(OP_ORD);
4255
4256         case KEY_oct:
4257             UNI(OP_OCT);
4258
4259         case KEY_opendir:
4260             LOP(OP_OPEN_DIR,XTERM);
4261
4262         case KEY_print:
4263             checkcomma(s,PL_tokenbuf,"filehandle");
4264             LOP(OP_PRINT,XREF);
4265
4266         case KEY_printf:
4267             checkcomma(s,PL_tokenbuf,"filehandle");
4268             LOP(OP_PRTF,XREF);
4269
4270         case KEY_prototype:
4271             UNI(OP_PROTOTYPE);
4272
4273         case KEY_push:
4274             LOP(OP_PUSH,XTERM);
4275
4276         case KEY_pop:
4277             UNI(OP_POP);
4278
4279         case KEY_pos:
4280             UNI(OP_POS);
4281
4282         case KEY_pack:
4283             LOP(OP_PACK,XTERM);
4284
4285         case KEY_package:
4286             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4287             OPERATOR(PACKAGE);
4288
4289         case KEY_pipe:
4290             LOP(OP_PIPE_OP,XTERM);
4291
4292         case KEY_q:
4293             s = scan_str(s,FALSE,FALSE);
4294             if (!s)
4295                 missingterm((char*)0);
4296             yylval.ival = OP_CONST;
4297             TERM(sublex_start());
4298
4299         case KEY_quotemeta:
4300             UNI(OP_QUOTEMETA);
4301
4302         case KEY_qw:
4303             s = scan_str(s,FALSE,FALSE);
4304             if (!s)
4305                 missingterm((char*)0);
4306             force_next(')');
4307             if (SvCUR(PL_lex_stuff)) {
4308                 OP *words = Nullop;
4309                 int warned = 0;
4310                 d = SvPV_force(PL_lex_stuff, len);
4311                 while (len) {
4312                     for (; isSPACE(*d) && len; --len, ++d) ;
4313                     if (len) {
4314                         char *b = d;
4315                         if (!warned && ckWARN(WARN_SYNTAX)) {
4316                             for (; !isSPACE(*d) && len; --len, ++d) {
4317                                 if (*d == ',') {
4318                                     Perl_warner(aTHX_ WARN_SYNTAX,
4319                                         "Possible attempt to separate words with commas");
4320                                     ++warned;
4321                                 }
4322                                 else if (*d == '#') {
4323                                     Perl_warner(aTHX_ WARN_SYNTAX,
4324                                         "Possible attempt to put comments in qw() list");
4325                                     ++warned;
4326                                 }
4327                             }
4328                         }
4329                         else {
4330                             for (; !isSPACE(*d) && len; --len, ++d) ;
4331                         }
4332                         words = append_elem(OP_LIST, words,
4333                                             newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4334                     }
4335                 }
4336                 if (words) {
4337                     PL_nextval[PL_nexttoke].opval = words;
4338                     force_next(THING);
4339                 }
4340             }
4341             if (PL_lex_stuff)
4342                 SvREFCNT_dec(PL_lex_stuff);
4343             PL_lex_stuff = Nullsv;
4344             PL_expect = XTERM;
4345             TOKEN('(');
4346
4347         case KEY_qq:
4348             s = scan_str(s,FALSE,FALSE);
4349             if (!s)
4350                 missingterm((char*)0);
4351             yylval.ival = OP_STRINGIFY;
4352             if (SvIVX(PL_lex_stuff) == '\'')
4353                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4354             TERM(sublex_start());
4355
4356         case KEY_qr:
4357             s = scan_pat(s,OP_QR);
4358             TERM(sublex_start());
4359
4360         case KEY_qx:
4361             s = scan_str(s,FALSE,FALSE);
4362             if (!s)
4363                 missingterm((char*)0);
4364             yylval.ival = OP_BACKTICK;
4365             set_csh();
4366             TERM(sublex_start());
4367
4368         case KEY_return:
4369             OLDLOP(OP_RETURN);
4370
4371         case KEY_require:
4372             *PL_tokenbuf = '\0';
4373             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4374             if (isIDFIRST_lazy(PL_tokenbuf))
4375                 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4376             else if (*s == '<')
4377                 yyerror("<> should be quotes");
4378             UNI(OP_REQUIRE);
4379
4380         case KEY_reset:
4381             UNI(OP_RESET);
4382
4383         case KEY_redo:
4384             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4385             LOOPX(OP_REDO);
4386
4387         case KEY_rename:
4388             LOP(OP_RENAME,XTERM);
4389
4390         case KEY_rand:
4391             UNI(OP_RAND);
4392
4393         case KEY_rmdir:
4394             UNI(OP_RMDIR);
4395
4396         case KEY_rindex:
4397             LOP(OP_RINDEX,XTERM);
4398
4399         case KEY_read:
4400             LOP(OP_READ,XTERM);
4401
4402         case KEY_readdir:
4403             UNI(OP_READDIR);
4404
4405         case KEY_readline:
4406             set_csh();
4407             UNI(OP_READLINE);
4408
4409         case KEY_readpipe:
4410             set_csh();
4411             UNI(OP_BACKTICK);
4412
4413         case KEY_rewinddir:
4414             UNI(OP_REWINDDIR);
4415
4416         case KEY_recv:
4417             LOP(OP_RECV,XTERM);
4418
4419         case KEY_reverse:
4420             LOP(OP_REVERSE,XTERM);
4421
4422         case KEY_readlink:
4423             UNI(OP_READLINK);
4424
4425         case KEY_ref:
4426             UNI(OP_REF);
4427
4428         case KEY_s:
4429             s = scan_subst(s);
4430             if (yylval.opval)
4431                 TERM(sublex_start());
4432             else
4433                 TOKEN(1);       /* force error */
4434
4435         case KEY_chomp:
4436             UNI(OP_CHOMP);
4437
4438         case KEY_scalar:
4439             UNI(OP_SCALAR);
4440
4441         case KEY_select:
4442             LOP(OP_SELECT,XTERM);
4443
4444         case KEY_seek:
4445             LOP(OP_SEEK,XTERM);
4446
4447         case KEY_semctl:
4448             LOP(OP_SEMCTL,XTERM);
4449
4450         case KEY_semget:
4451             LOP(OP_SEMGET,XTERM);
4452
4453         case KEY_semop:
4454             LOP(OP_SEMOP,XTERM);
4455
4456         case KEY_send:
4457             LOP(OP_SEND,XTERM);
4458
4459         case KEY_setpgrp:
4460             LOP(OP_SETPGRP,XTERM);
4461
4462         case KEY_setpriority:
4463             LOP(OP_SETPRIORITY,XTERM);
4464
4465         case KEY_sethostent:
4466             UNI(OP_SHOSTENT);
4467
4468         case KEY_setnetent:
4469             UNI(OP_SNETENT);
4470
4471         case KEY_setservent:
4472             UNI(OP_SSERVENT);
4473
4474         case KEY_setprotoent:
4475             UNI(OP_SPROTOENT);
4476
4477         case KEY_setpwent:
4478             FUN0(OP_SPWENT);
4479
4480         case KEY_setgrent:
4481             FUN0(OP_SGRENT);
4482
4483         case KEY_seekdir:
4484             LOP(OP_SEEKDIR,XTERM);
4485
4486         case KEY_setsockopt:
4487             LOP(OP_SSOCKOPT,XTERM);
4488
4489         case KEY_shift:
4490             UNI(OP_SHIFT);
4491
4492         case KEY_shmctl:
4493             LOP(OP_SHMCTL,XTERM);
4494
4495         case KEY_shmget:
4496             LOP(OP_SHMGET,XTERM);
4497
4498         case KEY_shmread:
4499             LOP(OP_SHMREAD,XTERM);
4500
4501         case KEY_shmwrite:
4502             LOP(OP_SHMWRITE,XTERM);
4503
4504         case KEY_shutdown:
4505             LOP(OP_SHUTDOWN,XTERM);
4506
4507         case KEY_sin:
4508             UNI(OP_SIN);
4509
4510         case KEY_sleep:
4511             UNI(OP_SLEEP);
4512
4513         case KEY_socket:
4514             LOP(OP_SOCKET,XTERM);
4515
4516         case KEY_socketpair:
4517             LOP(OP_SOCKPAIR,XTERM);
4518
4519         case KEY_sort:
4520             checkcomma(s,PL_tokenbuf,"subroutine name");
4521             s = skipspace(s);
4522             if (*s == ';' || *s == ')')         /* probably a close */
4523                 Perl_croak(aTHX_ "sort is now a reserved word");
4524             PL_expect = XTERM;
4525             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4526             LOP(OP_SORT,XREF);
4527
4528         case KEY_split:
4529             LOP(OP_SPLIT,XTERM);
4530
4531         case KEY_sprintf:
4532             LOP(OP_SPRINTF,XTERM);
4533
4534         case KEY_splice:
4535             LOP(OP_SPLICE,XTERM);
4536
4537         case KEY_sqrt:
4538             UNI(OP_SQRT);
4539
4540         case KEY_srand:
4541             UNI(OP_SRAND);
4542
4543         case KEY_stat:
4544             UNI(OP_STAT);
4545
4546         case KEY_study:
4547             PL_sawstudy++;
4548             UNI(OP_STUDY);
4549
4550         case KEY_substr:
4551             LOP(OP_SUBSTR,XTERM);
4552
4553         case KEY_format:
4554         case KEY_sub:
4555           really_sub:
4556             {
4557                 char tmpbuf[sizeof PL_tokenbuf];
4558                 SSize_t tboffset;
4559                 expectation attrful;
4560                 bool have_name, have_proto;
4561                 int key = tmp;
4562
4563                 s = skipspace(s);
4564
4565                 if (isIDFIRST_lazy(s) || *s == '\'' ||
4566                     (*s == ':' && s[1] == ':'))
4567                 {
4568                     PL_expect = XBLOCK;
4569                     attrful = XATTRBLOCK;
4570                     /* remember buffer pos'n for later force_word */
4571                     tboffset = s - PL_oldbufptr;
4572                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4573                     if (strchr(tmpbuf, ':'))
4574                         sv_setpv(PL_subname, tmpbuf);
4575                     else {
4576                         sv_setsv(PL_subname,PL_curstname);
4577                         sv_catpvn(PL_subname,"::",2);
4578                         sv_catpvn(PL_subname,tmpbuf,len);
4579                     }
4580                     s = skipspace(d);
4581                     have_name = TRUE;
4582                 }
4583                 else {
4584                     if (key == KEY_my)
4585                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
4586                     PL_expect = XTERMBLOCK;
4587                     attrful = XATTRTERM;
4588                     sv_setpv(PL_subname,"?");
4589                     have_name = FALSE;
4590                 }
4591
4592                 if (key == KEY_format) {
4593                     if (*s == '=')
4594                         PL_lex_formbrack = PL_lex_brackets + 1;
4595                     if (have_name)
4596                         (void) force_word(PL_oldbufptr + tboffset, WORD,
4597                                           FALSE, TRUE, TRUE);
4598                     OPERATOR(FORMAT);
4599                 }
4600
4601                 /* Look for a prototype */
4602                 if (*s == '(') {
4603                     char *p;
4604
4605                     s = scan_str(s,FALSE,FALSE);
4606                     if (!s) {
4607                         if (PL_lex_stuff)
4608                             SvREFCNT_dec(PL_lex_stuff);
4609                         PL_lex_stuff = Nullsv;
4610                         Perl_croak(aTHX_ "Prototype not terminated");
4611                     }
4612                     /* strip spaces */
4613                     d = SvPVX(PL_lex_stuff);
4614                     tmp = 0;
4615                     for (p = d; *p; ++p) {
4616                         if (!isSPACE(*p))
4617                             d[tmp++] = *p;
4618                     }
4619                     d[tmp] = '\0';
4620                     SvCUR(PL_lex_stuff) = tmp;
4621                     have_proto = TRUE;
4622
4623                     s = skipspace(s);
4624                 }
4625                 else
4626                     have_proto = FALSE;
4627
4628                 if (*s == ':' && s[1] != ':')
4629                     PL_expect = attrful;
4630
4631                 if (have_proto) {
4632                     PL_nextval[PL_nexttoke].opval =
4633                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4634                     PL_lex_stuff = Nullsv;
4635                     force_next(THING);
4636                 }
4637                 if (!have_name) {
4638                     sv_setpv(PL_subname,"__ANON__");
4639                     TOKEN(ANONSUB);
4640                 }
4641                 (void) force_word(PL_oldbufptr + tboffset, WORD,
4642                                   FALSE, TRUE, TRUE);
4643                 if (key == KEY_my)
4644                     TOKEN(MYSUB);
4645                 TOKEN(SUB);
4646             }
4647
4648         case KEY_system:
4649             set_csh();
4650             LOP(OP_SYSTEM,XREF);
4651
4652         case KEY_symlink:
4653             LOP(OP_SYMLINK,XTERM);
4654
4655         case KEY_syscall:
4656             LOP(OP_SYSCALL,XTERM);
4657
4658         case KEY_sysopen:
4659             LOP(OP_SYSOPEN,XTERM);
4660
4661         case KEY_sysseek:
4662             LOP(OP_SYSSEEK,XTERM);
4663
4664         case KEY_sysread:
4665             LOP(OP_SYSREAD,XTERM);
4666
4667         case KEY_syswrite:
4668             LOP(OP_SYSWRITE,XTERM);
4669
4670         case KEY_tr:
4671             s = scan_trans(s);
4672             TERM(sublex_start());
4673
4674         case KEY_tell:
4675             UNI(OP_TELL);
4676
4677         case KEY_telldir:
4678             UNI(OP_TELLDIR);
4679
4680         case KEY_tie:
4681             LOP(OP_TIE,XTERM);
4682
4683         case KEY_tied:
4684             UNI(OP_TIED);
4685
4686         case KEY_time:
4687             FUN0(OP_TIME);
4688
4689         case KEY_times:
4690             FUN0(OP_TMS);
4691
4692         case KEY_truncate:
4693             LOP(OP_TRUNCATE,XTERM);
4694
4695         case KEY_uc:
4696             UNI(OP_UC);
4697
4698         case KEY_ucfirst:
4699             UNI(OP_UCFIRST);
4700
4701         case KEY_untie:
4702             UNI(OP_UNTIE);
4703
4704         case KEY_until:
4705             yylval.ival = PL_curcop->cop_line;
4706             OPERATOR(UNTIL);
4707
4708         case KEY_unless:
4709             yylval.ival = PL_curcop->cop_line;
4710             OPERATOR(UNLESS);
4711
4712         case KEY_unlink:
4713             LOP(OP_UNLINK,XTERM);
4714
4715         case KEY_undef:
4716             UNI(OP_UNDEF);
4717
4718         case KEY_unpack:
4719             LOP(OP_UNPACK,XTERM);
4720
4721         case KEY_utime:
4722             LOP(OP_UTIME,XTERM);
4723
4724         case KEY_umask:
4725             if (ckWARN(WARN_OCTAL)) {
4726                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4727                 if (*d != '0' && isDIGIT(*d))
4728                     Perl_warner(aTHX_ WARN_OCTAL,
4729                                 "umask: argument is missing initial 0");
4730             }
4731             UNI(OP_UMASK);
4732
4733         case KEY_unshift:
4734             LOP(OP_UNSHIFT,XTERM);
4735
4736         case KEY_use:
4737             if (PL_expect != XSTATE)
4738                 yyerror("\"use\" not allowed in expression");
4739             s = skipspace(s);
4740             if(isDIGIT(*s)) {
4741                 s = force_version(s);
4742                 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4743                     PL_nextval[PL_nexttoke].opval = Nullop;
4744                     force_next(WORD);
4745                 }
4746             }
4747             else {
4748                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4749                 s = force_version(s);
4750             }
4751             yylval.ival = 1;
4752             OPERATOR(USE);
4753
4754         case KEY_values:
4755             UNI(OP_VALUES);
4756
4757         case KEY_vec:
4758             PL_sawvec = TRUE;
4759             LOP(OP_VEC,XTERM);
4760
4761         case KEY_while:
4762             yylval.ival = PL_curcop->cop_line;
4763             OPERATOR(WHILE);
4764
4765         case KEY_warn:
4766             PL_hints |= HINT_BLOCK_SCOPE;
4767             LOP(OP_WARN,XTERM);
4768
4769         case KEY_wait:
4770             FUN0(OP_WAIT);
4771
4772         case KEY_waitpid:
4773             LOP(OP_WAITPID,XTERM);
4774
4775         case KEY_wantarray:
4776             FUN0(OP_WANTARRAY);
4777
4778         case KEY_write:
4779 #ifdef EBCDIC
4780         {
4781             static char ctl_l[2];
4782
4783             if (ctl_l[0] == '\0')
4784                 ctl_l[0] = toCTRL('L');
4785             gv_fetchpv(ctl_l,TRUE, SVt_PV);
4786         }
4787 #else
4788             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4789 #endif
4790             UNI(OP_ENTERWRITE);
4791
4792         case KEY_x:
4793             if (PL_expect == XOPERATOR)
4794                 Mop(OP_REPEAT);
4795             check_uni();
4796             goto just_a_word;
4797
4798         case KEY_xor:
4799             yylval.ival = OP_XOR;
4800             OPERATOR(OROP);
4801
4802         case KEY_y:
4803             s = scan_trans(s);
4804             TERM(sublex_start());
4805         }
4806     }}
4807 }
4808
4809 I32
4810 Perl_keyword(pTHX_ register char *d, I32 len)
4811 {
4812     switch (*d) {
4813     case '_':
4814         if (d[1] == '_') {
4815             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4816             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4817             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4818             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4819             if (strEQ(d,"__END__"))             return KEY___END__;
4820         }
4821         break;
4822     case 'A':
4823         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4824         break;
4825     case 'a':
4826         switch (len) {
4827         case 3:
4828             if (strEQ(d,"and"))                 return -KEY_and;
4829             if (strEQ(d,"abs"))                 return -KEY_abs;
4830             break;
4831         case 5:
4832             if (strEQ(d,"alarm"))               return -KEY_alarm;
4833             if (strEQ(d,"atan2"))               return -KEY_atan2;
4834             break;
4835         case 6:
4836             if (strEQ(d,"accept"))              return -KEY_accept;
4837             break;
4838         }
4839         break;
4840     case 'B':
4841         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4842         break;
4843     case 'b':
4844         if (strEQ(d,"bless"))                   return -KEY_bless;
4845         if (strEQ(d,"bind"))                    return -KEY_bind;
4846         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4847         break;
4848     case 'C':
4849         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4850         break;
4851     case 'c':
4852         switch (len) {
4853         case 3:
4854             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4855             if (strEQ(d,"chr"))                 return -KEY_chr;
4856             if (strEQ(d,"cos"))                 return -KEY_cos;
4857             break;
4858         case 4:
4859             if (strEQ(d,"chop"))                return KEY_chop;
4860             break;
4861         case 5:
4862             if (strEQ(d,"close"))               return -KEY_close;
4863             if (strEQ(d,"chdir"))               return -KEY_chdir;
4864             if (strEQ(d,"chomp"))               return KEY_chomp;
4865             if (strEQ(d,"chmod"))               return -KEY_chmod;
4866             if (strEQ(d,"chown"))               return -KEY_chown;
4867             if (strEQ(d,"crypt"))               return -KEY_crypt;
4868             break;
4869         case 6:
4870             if (strEQ(d,"chroot"))              return -KEY_chroot;
4871             if (strEQ(d,"caller"))              return -KEY_caller;
4872             break;
4873         case 7:
4874             if (strEQ(d,"connect"))             return -KEY_connect;
4875             break;
4876         case 8:
4877             if (strEQ(d,"closedir"))            return -KEY_closedir;
4878             if (strEQ(d,"continue"))            return -KEY_continue;
4879             break;
4880         }
4881         break;
4882     case 'D':
4883         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4884         break;
4885     case 'd':
4886         switch (len) {
4887         case 2:
4888             if (strEQ(d,"do"))                  return KEY_do;
4889             break;
4890         case 3:
4891             if (strEQ(d,"die"))                 return -KEY_die;
4892             break;
4893         case 4:
4894             if (strEQ(d,"dump"))                return -KEY_dump;
4895             break;
4896         case 6:
4897             if (strEQ(d,"delete"))              return KEY_delete;
4898             break;
4899         case 7:
4900             if (strEQ(d,"defined"))             return KEY_defined;
4901             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
4902             break;
4903         case 8:
4904             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
4905             break;
4906         }
4907         break;
4908     case 'E':
4909         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
4910         if (strEQ(d,"END"))                     return KEY_END;
4911         break;
4912     case 'e':
4913         switch (len) {
4914         case 2:
4915             if (strEQ(d,"eq"))                  return -KEY_eq;
4916             break;
4917         case 3:
4918             if (strEQ(d,"eof"))                 return -KEY_eof;
4919             if (strEQ(d,"exp"))                 return -KEY_exp;
4920             break;
4921         case 4:
4922             if (strEQ(d,"else"))                return KEY_else;
4923             if (strEQ(d,"exit"))                return -KEY_exit;
4924             if (strEQ(d,"eval"))                return KEY_eval;
4925             if (strEQ(d,"exec"))                return -KEY_exec;
4926             if (strEQ(d,"each"))                return KEY_each;
4927             break;
4928         case 5:
4929             if (strEQ(d,"elsif"))               return KEY_elsif;
4930             break;
4931         case 6:
4932             if (strEQ(d,"exists"))              return KEY_exists;
4933             if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4934             break;
4935         case 8:
4936             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
4937             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
4938             break;
4939         case 9:
4940             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
4941             break;
4942         case 10:
4943             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
4944             if (strEQ(d,"endservent"))          return -KEY_endservent;
4945             break;
4946         case 11:
4947             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
4948             break;
4949         }
4950         break;
4951     case 'f':
4952         switch (len) {
4953         case 3:
4954             if (strEQ(d,"for"))                 return KEY_for;
4955             break;
4956         case 4:
4957             if (strEQ(d,"fork"))                return -KEY_fork;
4958             break;
4959         case 5:
4960             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
4961             if (strEQ(d,"flock"))               return -KEY_flock;
4962             break;
4963         case 6:
4964             if (strEQ(d,"format"))              return KEY_format;
4965             if (strEQ(d,"fileno"))              return -KEY_fileno;
4966             break;
4967         case 7:
4968             if (strEQ(d,"foreach"))             return KEY_foreach;
4969             break;
4970         case 8:
4971             if (strEQ(d,"formline"))            return -KEY_formline;
4972             break;
4973         }
4974         break;
4975     case 'G':
4976         if (len == 2) {
4977             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
4978             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
4979         }
4980         break;
4981     case 'g':
4982         if (strnEQ(d,"get",3)) {
4983             d += 3;
4984             if (*d == 'p') {
4985                 switch (len) {
4986                 case 7:
4987                     if (strEQ(d,"ppid"))        return -KEY_getppid;
4988                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
4989                     break;
4990                 case 8:
4991                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
4992                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
4993                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
4994                     break;
4995                 case 11:
4996                     if (strEQ(d,"peername"))    return -KEY_getpeername;
4997                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
4998                     if (strEQ(d,"priority"))    return -KEY_getpriority;
4999                     break;
5000                 case 14:
5001                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5002                     break;
5003                 case 16:
5004                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5005                     break;
5006                 }
5007             }
5008             else if (*d == 'h') {
5009                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
5010                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
5011                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
5012             }
5013             else if (*d == 'n') {
5014                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
5015                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
5016                 if (strEQ(d,"netent"))          return -KEY_getnetent;
5017             }
5018             else if (*d == 's') {
5019                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
5020                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
5021                 if (strEQ(d,"servent"))         return -KEY_getservent;
5022                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
5023                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
5024             }
5025             else if (*d == 'g') {
5026                 if (strEQ(d,"grent"))           return -KEY_getgrent;
5027                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
5028                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
5029             }
5030             else if (*d == 'l') {
5031                 if (strEQ(d,"login"))           return -KEY_getlogin;
5032             }
5033             else if (strEQ(d,"c"))              return -KEY_getc;
5034             break;
5035         }
5036         switch (len) {
5037         case 2:
5038             if (strEQ(d,"gt"))                  return -KEY_gt;
5039             if (strEQ(d,"ge"))                  return -KEY_ge;
5040             break;
5041         case 4:
5042             if (strEQ(d,"grep"))                return KEY_grep;
5043             if (strEQ(d,"goto"))                return KEY_goto;
5044             if (strEQ(d,"glob"))                return KEY_glob;
5045             break;
5046         case 6:
5047             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
5048             break;
5049         }
5050         break;
5051     case 'h':
5052         if (strEQ(d,"hex"))                     return -KEY_hex;
5053         break;
5054     case 'I':
5055         if (strEQ(d,"INIT"))                    return KEY_INIT;
5056         break;
5057     case 'i':
5058         switch (len) {
5059         case 2:
5060             if (strEQ(d,"if"))                  return KEY_if;
5061             break;
5062         case 3:
5063             if (strEQ(d,"int"))                 return -KEY_int;
5064             break;
5065         case 5:
5066             if (strEQ(d,"index"))               return -KEY_index;
5067             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
5068             break;
5069         }
5070         break;
5071     case 'j':
5072         if (strEQ(d,"join"))                    return -KEY_join;
5073         break;
5074     case 'k':
5075         if (len == 4) {
5076             if (strEQ(d,"keys"))                return KEY_keys;
5077             if (strEQ(d,"kill"))                return -KEY_kill;
5078         }
5079         break;
5080     case 'L':
5081         if (len == 2) {
5082             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
5083             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
5084         }
5085         break;
5086     case 'l':
5087         switch (len) {
5088         case 2:
5089             if (strEQ(d,"lt"))                  return -KEY_lt;
5090             if (strEQ(d,"le"))                  return -KEY_le;
5091             if (strEQ(d,"lc"))                  return -KEY_lc;
5092             break;
5093         case 3:
5094             if (strEQ(d,"log"))                 return -KEY_log;
5095             break;
5096         case 4:
5097             if (strEQ(d,"last"))                return KEY_last;
5098             if (strEQ(d,"link"))                return -KEY_link;
5099             if (strEQ(d,"lock"))                return -KEY_lock;
5100             break;
5101         case 5:
5102             if (strEQ(d,"local"))               return KEY_local;
5103             if (strEQ(d,"lstat"))               return -KEY_lstat;
5104             break;
5105         case 6:
5106             if (strEQ(d,"length"))              return -KEY_length;
5107             if (strEQ(d,"listen"))              return -KEY_listen;
5108             break;
5109         case 7:
5110             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
5111             break;
5112         case 9:
5113             if (strEQ(d,"localtime"))           return -KEY_localtime;
5114             break;
5115         }
5116         break;
5117     case 'm':
5118         switch (len) {
5119         case 1:                                 return KEY_m;
5120         case 2:
5121             if (strEQ(d,"my"))                  return KEY_my;
5122             break;
5123         case 3:
5124             if (strEQ(d,"map"))                 return KEY_map;
5125             break;
5126         case 5:
5127             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
5128             break;
5129         case 6:
5130             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
5131             if (strEQ(d,"msgget"))              return -KEY_msgget;
5132             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
5133             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
5134             break;
5135         }
5136         break;
5137     case 'N':
5138         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
5139         break;
5140     case 'n':
5141         if (strEQ(d,"next"))                    return KEY_next;
5142         if (strEQ(d,"ne"))                      return -KEY_ne;
5143         if (strEQ(d,"not"))                     return -KEY_not;
5144         if (strEQ(d,"no"))                      return KEY_no;
5145         break;
5146     case 'o':
5147         switch (len) {
5148         case 2:
5149             if (strEQ(d,"or"))                  return -KEY_or;
5150             break;
5151         case 3:
5152             if (strEQ(d,"ord"))                 return -KEY_ord;
5153             if (strEQ(d,"oct"))                 return -KEY_oct;
5154             if (strEQ(d,"our"))                 return KEY_our;
5155             break;
5156         case 4:
5157             if (strEQ(d,"open"))                return -KEY_open;
5158             break;
5159         case 7:
5160             if (strEQ(d,"opendir"))             return -KEY_opendir;
5161             break;
5162         }
5163         break;
5164     case 'p':
5165         switch (len) {
5166         case 3:
5167             if (strEQ(d,"pop"))                 return KEY_pop;
5168             if (strEQ(d,"pos"))                 return KEY_pos;
5169             break;
5170         case 4:
5171             if (strEQ(d,"push"))                return KEY_push;
5172             if (strEQ(d,"pack"))                return -KEY_pack;
5173             if (strEQ(d,"pipe"))                return -KEY_pipe;
5174             break;
5175         case 5:
5176             if (strEQ(d,"print"))               return KEY_print;
5177             break;
5178         case 6:
5179             if (strEQ(d,"printf"))              return KEY_printf;
5180             break;
5181         case 7:
5182             if (strEQ(d,"package"))             return KEY_package;
5183             break;
5184         case 9:
5185             if (strEQ(d,"prototype"))           return KEY_prototype;
5186         }
5187         break;
5188     case 'q':
5189         if (len <= 2) {
5190             if (strEQ(d,"q"))                   return KEY_q;
5191             if (strEQ(d,"qr"))                  return KEY_qr;
5192             if (strEQ(d,"qq"))                  return KEY_qq;
5193             if (strEQ(d,"qw"))                  return KEY_qw;
5194             if (strEQ(d,"qx"))                  return KEY_qx;
5195         }
5196         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
5197         break;
5198     case 'r':
5199         switch (len) {
5200         case 3:
5201             if (strEQ(d,"ref"))                 return -KEY_ref;
5202             break;
5203         case 4:
5204             if (strEQ(d,"read"))                return -KEY_read;
5205             if (strEQ(d,"rand"))                return -KEY_rand;
5206             if (strEQ(d,"recv"))                return -KEY_recv;
5207             if (strEQ(d,"redo"))                return KEY_redo;
5208             break;
5209         case 5:
5210             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
5211             if (strEQ(d,"reset"))               return -KEY_reset;
5212             break;
5213         case 6:
5214             if (strEQ(d,"return"))              return KEY_return;
5215             if (strEQ(d,"rename"))              return -KEY_rename;
5216             if (strEQ(d,"rindex"))              return -KEY_rindex;
5217             break;
5218         case 7:
5219             if (strEQ(d,"require"))             return -KEY_require;
5220             if (strEQ(d,"reverse"))             return -KEY_reverse;
5221             if (strEQ(d,"readdir"))             return -KEY_readdir;
5222             break;
5223         case 8:
5224             if (strEQ(d,"readlink"))            return -KEY_readlink;
5225             if (strEQ(d,"readline"))            return -KEY_readline;
5226             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5227             break;
5228         case 9:
5229             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5230             break;
5231         }
5232         break;
5233     case 's':
5234         switch (d[1]) {
5235         case 0:                                 return KEY_s;
5236         case 'c':
5237             if (strEQ(d,"scalar"))              return KEY_scalar;
5238             break;
5239         case 'e':
5240             switch (len) {
5241             case 4:
5242                 if (strEQ(d,"seek"))            return -KEY_seek;
5243                 if (strEQ(d,"send"))            return -KEY_send;
5244                 break;
5245             case 5:
5246                 if (strEQ(d,"semop"))           return -KEY_semop;
5247                 break;
5248             case 6:
5249                 if (strEQ(d,"select"))          return -KEY_select;
5250                 if (strEQ(d,"semctl"))          return -KEY_semctl;
5251                 if (strEQ(d,"semget"))          return -KEY_semget;
5252                 break;
5253             case 7:
5254                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
5255                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
5256                 break;
5257             case 8:
5258                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
5259                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
5260                 break;
5261             case 9:
5262                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
5263                 break;
5264             case 10:
5265                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
5266                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
5267                 if (strEQ(d,"setservent"))      return -KEY_setservent;
5268                 break;
5269             case 11:
5270                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
5271                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
5272                 break;
5273             }
5274             break;
5275         case 'h':
5276             switch (len) {
5277             case 5:
5278                 if (strEQ(d,"shift"))           return KEY_shift;
5279                 break;
5280             case 6:
5281                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
5282                 if (strEQ(d,"shmget"))          return -KEY_shmget;
5283                 break;
5284             case 7:
5285                 if (strEQ(d,"shmread"))         return -KEY_shmread;
5286                 break;
5287             case 8:
5288                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
5289                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
5290                 break;
5291             }
5292             break;
5293         case 'i':
5294             if (strEQ(d,"sin"))                 return -KEY_sin;
5295             break;
5296         case 'l':
5297             if (strEQ(d,"sleep"))               return -KEY_sleep;
5298             break;
5299         case 'o':
5300             if (strEQ(d,"sort"))                return KEY_sort;
5301             if (strEQ(d,"socket"))              return -KEY_socket;
5302             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
5303             break;
5304         case 'p':
5305             if (strEQ(d,"split"))               return KEY_split;
5306             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
5307             if (strEQ(d,"splice"))              return KEY_splice;
5308             break;
5309         case 'q':
5310             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
5311             break;
5312         case 'r':
5313             if (strEQ(d,"srand"))               return -KEY_srand;
5314             break;
5315         case 't':
5316             if (strEQ(d,"stat"))                return -KEY_stat;
5317             if (strEQ(d,"study"))               return KEY_study;
5318             break;
5319         case 'u':
5320             if (strEQ(d,"substr"))              return -KEY_substr;
5321             if (strEQ(d,"sub"))                 return KEY_sub;
5322             break;
5323         case 'y':
5324             switch (len) {
5325             case 6:
5326                 if (strEQ(d,"system"))          return -KEY_system;
5327                 break;
5328             case 7:
5329                 if (strEQ(d,"symlink"))         return -KEY_symlink;
5330                 if (strEQ(d,"syscall"))         return -KEY_syscall;
5331                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
5332                 if (strEQ(d,"sysread"))         return -KEY_sysread;
5333                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
5334                 break;
5335             case 8:
5336                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
5337                 break;
5338             }
5339             break;
5340         }
5341         break;
5342     case 't':
5343         switch (len) {
5344         case 2:
5345             if (strEQ(d,"tr"))                  return KEY_tr;
5346             break;
5347         case 3:
5348             if (strEQ(d,"tie"))                 return KEY_tie;
5349             break;
5350         case 4:
5351             if (strEQ(d,"tell"))                return -KEY_tell;
5352             if (strEQ(d,"tied"))                return KEY_tied;
5353             if (strEQ(d,"time"))                return -KEY_time;
5354             break;
5355         case 5:
5356             if (strEQ(d,"times"))               return -KEY_times;
5357             break;
5358         case 7:
5359             if (strEQ(d,"telldir"))             return -KEY_telldir;
5360             break;
5361         case 8:
5362             if (strEQ(d,"truncate"))            return -KEY_truncate;
5363             break;
5364         }
5365         break;
5366     case 'u':
5367         switch (len) {
5368         case 2:
5369             if (strEQ(d,"uc"))                  return -KEY_uc;
5370             break;
5371         case 3:
5372             if (strEQ(d,"use"))                 return KEY_use;
5373             break;
5374         case 5:
5375             if (strEQ(d,"undef"))               return KEY_undef;
5376             if (strEQ(d,"until"))               return KEY_until;
5377             if (strEQ(d,"untie"))               return KEY_untie;
5378             if (strEQ(d,"utime"))               return -KEY_utime;
5379             if (strEQ(d,"umask"))               return -KEY_umask;
5380             break;
5381         case 6:
5382             if (strEQ(d,"unless"))              return KEY_unless;
5383             if (strEQ(d,"unpack"))              return -KEY_unpack;
5384             if (strEQ(d,"unlink"))              return -KEY_unlink;
5385             break;
5386         case 7:
5387             if (strEQ(d,"unshift"))             return KEY_unshift;
5388             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
5389             break;
5390         }
5391         break;
5392     case 'v':
5393         if (strEQ(d,"values"))                  return -KEY_values;
5394         if (strEQ(d,"vec"))                     return -KEY_vec;
5395         break;
5396     case 'w':
5397         switch (len) {
5398         case 4:
5399             if (strEQ(d,"warn"))                return -KEY_warn;
5400             if (strEQ(d,"wait"))                return -KEY_wait;
5401             break;
5402         case 5:
5403             if (strEQ(d,"while"))               return KEY_while;
5404             if (strEQ(d,"write"))               return -KEY_write;
5405             break;
5406         case 7:
5407             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
5408             break;
5409         case 9:
5410             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
5411             break;
5412         }
5413         break;
5414     case 'x':
5415         if (len == 1)                           return -KEY_x;
5416         if (strEQ(d,"xor"))                     return -KEY_xor;
5417         break;
5418     case 'y':
5419         if (len == 1)                           return KEY_y;
5420         break;
5421     case 'z':
5422         break;
5423     }
5424     return 0;
5425 }
5426
5427 STATIC void
5428 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5429 {
5430     char *w;
5431
5432     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
5433         dTHR;                           /* only for ckWARN */
5434         if (ckWARN(WARN_SYNTAX)) {
5435             int level = 1;
5436             for (w = s+2; *w && level; w++) {
5437                 if (*w == '(')
5438                     ++level;
5439                 else if (*w == ')')
5440                     --level;
5441             }
5442             if (*w)
5443                 for (; *w && isSPACE(*w); w++) ;
5444             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
5445                 Perl_warner(aTHX_ WARN_SYNTAX,
5446                             "%s (...) interpreted as function",name);
5447         }
5448     }
5449     while (s < PL_bufend && isSPACE(*s))
5450         s++;
5451     if (*s == '(')
5452         s++;
5453     while (s < PL_bufend && isSPACE(*s))
5454         s++;
5455     if (isIDFIRST_lazy(s)) {
5456         w = s++;
5457         while (isALNUM_lazy(s))
5458             s++;
5459         while (s < PL_bufend && isSPACE(*s))
5460             s++;
5461         if (*s == ',') {
5462             int kw;
5463             *s = '\0';
5464             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5465             *s = ',';
5466             if (kw)
5467                 return;
5468             Perl_croak(aTHX_ "No comma allowed after %s", what);
5469         }
5470     }
5471 }
5472
5473 /* Either returns sv, or mortalizes sv and returns a new SV*.
5474    Best used as sv=new_constant(..., sv, ...).
5475    If s, pv are NULL, calls subroutine with one argument,
5476    and type is used with error messages only. */
5477
5478 STATIC SV *
5479 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
5480 {
5481     dSP;
5482     HV *table = GvHV(PL_hintgv);                 /* ^H */
5483     SV *res;
5484     SV **cvp;
5485     SV *cv, *typesv;
5486     char *why, *why1, *why2;
5487
5488     if (!(PL_hints & HINT_LOCALIZE_HH)) {
5489         SV *msg;
5490
5491         why = "%^H is not localized";
5492     report_short:
5493         why1 = why2 = "";
5494     report:
5495         msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5496                             (type ? type: "undef"), why1, why2, why);
5497         yyerror(SvPVX(msg));
5498         SvREFCNT_dec(msg);
5499         return sv;
5500     }
5501     if (!table) {
5502         why = "%^H is not defined";
5503         goto report_short;
5504     }
5505     cvp = hv_fetch(table, key, strlen(key), FALSE);
5506     if (!cvp || !SvOK(*cvp)) {
5507         why = "} is not defined";
5508         why1 = "$^H{";
5509         why2 = key;
5510         goto report;
5511     }
5512     sv_2mortal(sv);                     /* Parent created it permanently */
5513     cv = *cvp;
5514     if (!pv && s)
5515         pv = sv_2mortal(newSVpvn(s, len));
5516     if (type && pv)
5517         typesv = sv_2mortal(newSVpv(type, 0));
5518     else
5519         typesv = &PL_sv_undef;
5520
5521     PUSHSTACKi(PERLSI_OVERLOAD);
5522     ENTER ;
5523     SAVETMPS;
5524
5525     PUSHMARK(SP) ;
5526     EXTEND(sp, 4);
5527     if (pv)
5528         PUSHs(pv);
5529     PUSHs(sv);
5530     if (pv)
5531         PUSHs(typesv);
5532     PUSHs(cv);
5533     PUTBACK;
5534     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5535
5536     SPAGAIN ;
5537
5538     /* Check the eval first */
5539     if (!PL_in_eval && SvTRUE(ERRSV))
5540     {
5541         STRLEN n_a;
5542         sv_catpv(ERRSV, "Propagated");
5543         yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5544         POPs ;
5545         res = SvREFCNT_inc(sv);
5546     }
5547     else {
5548         res = POPs;
5549         SvREFCNT_inc(res);
5550     }
5551
5552     PUTBACK ;
5553     FREETMPS ;
5554     LEAVE ;
5555     POPSTACK;
5556
5557     if (!SvOK(res)) {
5558         why = "}} did not return a defined value";
5559         why1 = "Call to &{$^H{";
5560         why2 = key;
5561         sv = res;
5562         goto report;
5563      }
5564
5565      return res;
5566 }
5567
5568 STATIC char *
5569 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5570 {
5571     register char *d = dest;
5572     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
5573     for (;;) {
5574         if (d >= e)
5575             Perl_croak(aTHX_ ident_too_long);
5576         if (isALNUM(*s))        /* UTF handled below */
5577             *d++ = *s++;
5578         else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5579             *d++ = ':';
5580             *d++ = ':';
5581             s++;
5582         }
5583         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5584             *d++ = *s++;
5585             *d++ = *s++;
5586         }
5587         else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5588             char *t = s + UTF8SKIP(s);
5589             while (*t & 0x80 && is_utf8_mark((U8*)t))
5590                 t += UTF8SKIP(t);
5591             if (d + (t - s) > e)
5592                 Perl_croak(aTHX_ ident_too_long);
5593             Copy(s, d, t - s, char);
5594             d += t - s;
5595             s = t;
5596         }
5597         else {
5598             *d = '\0';
5599             *slp = d - dest;
5600             return s;
5601         }
5602     }
5603 }
5604
5605 STATIC char *
5606 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5607 {
5608     register char *d;
5609     register char *e;
5610     char *bracket = 0;
5611     char funny = *s++;
5612
5613     if (PL_lex_brackets == 0)
5614         PL_lex_fakebrack = 0;
5615     if (isSPACE(*s))
5616         s = skipspace(s);
5617     d = dest;
5618     e = d + destlen - 3;        /* two-character token, ending NUL */
5619     if (isDIGIT(*s)) {
5620         while (isDIGIT(*s)) {
5621             if (d >= e)
5622                 Perl_croak(aTHX_ ident_too_long);
5623             *d++ = *s++;
5624         }
5625     }
5626     else {
5627         for (;;) {
5628             if (d >= e)
5629                 Perl_croak(aTHX_ ident_too_long);
5630             if (isALNUM(*s))    /* UTF handled below */
5631                 *d++ = *s++;
5632             else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5633                 *d++ = ':';
5634                 *d++ = ':';
5635                 s++;
5636             }
5637             else if (*s == ':' && s[1] == ':') {
5638                 *d++ = *s++;
5639                 *d++ = *s++;
5640             }
5641             else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5642                 char *t = s + UTF8SKIP(s);
5643                 while (*t & 0x80 && is_utf8_mark((U8*)t))
5644                     t += UTF8SKIP(t);
5645                 if (d + (t - s) > e)
5646                     Perl_croak(aTHX_ ident_too_long);
5647                 Copy(s, d, t - s, char);
5648                 d += t - s;
5649                 s = t;
5650             }
5651             else
5652                 break;
5653         }
5654     }
5655     *d = '\0';
5656     d = dest;
5657     if (*d) {
5658         if (PL_lex_state != LEX_NORMAL)
5659             PL_lex_state = LEX_INTERPENDMAYBE;
5660         return s;
5661     }
5662     if (*s == '$' && s[1] &&
5663         (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5664     {
5665         return s;
5666     }
5667     if (*s == '{') {
5668         bracket = s;
5669         s++;
5670     }
5671     else if (ck_uni)
5672         check_uni();
5673     if (s < send)
5674         *d = *s++;
5675     d[1] = '\0';
5676     if (*d == '^' && *s && isCONTROLVAR(*s)) {
5677         *d = toCTRL(*s);
5678         s++;
5679     }
5680     if (bracket) {
5681         if (isSPACE(s[-1])) {
5682             while (s < send) {
5683                 char ch = *s++;
5684                 if (ch != ' ' && ch != '\t') {
5685                     *d = ch;
5686                     break;
5687                 }
5688             }
5689         }
5690         if (isIDFIRST_lazy(d)) {
5691             d++;
5692             if (UTF) {
5693                 e = s;
5694                 while (e < send && isALNUM_lazy(e) || *e == ':') {
5695                     e += UTF8SKIP(e);
5696                     while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5697                         e += UTF8SKIP(e);
5698                 }
5699                 Copy(s, d, e - s, char);
5700                 d += e - s;
5701                 s = e;
5702             }
5703             else {
5704                 while ((isALNUM(*s) || *s == ':') && d < e)
5705                     *d++ = *s++;
5706                 if (d >= e)
5707                     Perl_croak(aTHX_ ident_too_long);
5708             }
5709             *d = '\0';
5710             while (s < send && (*s == ' ' || *s == '\t')) s++;
5711             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5712                 dTHR;                   /* only for ckWARN */
5713                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5714                     char *brack = *s == '[' ? "[...]" : "{...}";
5715                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
5716                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5717                         funny, dest, brack, funny, dest, brack);
5718                 }
5719                 PL_lex_fakebrack = PL_lex_brackets+1;
5720                 bracket++;
5721                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5722                 return s;
5723             }
5724         }
5725         /* Handle extended ${^Foo} variables
5726          * 1999-02-27 mjd-perl-patch@plover.com */
5727         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5728                  && isALNUM(*s))
5729         {
5730             d++;
5731             while (isALNUM(*s) && d < e) {
5732                 *d++ = *s++;
5733             }
5734             if (d >= e)
5735                 Perl_croak(aTHX_ ident_too_long);
5736             *d = '\0';
5737         }
5738         if (*s == '}') {
5739             s++;
5740             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5741                 PL_lex_state = LEX_INTERPEND;
5742             if (funny == '#')
5743                 funny = '@';
5744             if (PL_lex_state == LEX_NORMAL) {
5745                 dTHR;                   /* only for ckWARN */
5746                 if (ckWARN(WARN_AMBIGUOUS) &&
5747                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5748                 {
5749                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
5750                         "Ambiguous use of %c{%s} resolved to %c%s",
5751                         funny, dest, funny, dest);
5752                 }
5753             }
5754         }
5755         else {
5756             s = bracket;                /* let the parser handle it */
5757             *dest = '\0';
5758         }
5759     }
5760     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5761         PL_lex_state = LEX_INTERPEND;
5762     return s;
5763 }
5764
5765 void
5766 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5767 {
5768     if (ch == 'i')
5769         *pmfl |= PMf_FOLD;
5770     else if (ch == 'g')
5771         *pmfl |= PMf_GLOBAL;
5772     else if (ch == 'c')
5773         *pmfl |= PMf_CONTINUE;
5774     else if (ch == 'o')
5775         *pmfl |= PMf_KEEP;
5776     else if (ch == 'm')
5777         *pmfl |= PMf_MULTILINE;
5778     else if (ch == 's')
5779         *pmfl |= PMf_SINGLELINE;
5780     else if (ch == 'x')
5781         *pmfl |= PMf_EXTENDED;
5782 }
5783
5784 STATIC char *
5785 S_scan_pat(pTHX_ char *start, I32 type)
5786 {
5787     PMOP *pm;
5788     char *s;
5789
5790     s = scan_str(start,FALSE,FALSE);
5791     if (!s) {
5792         if (PL_lex_stuff)
5793             SvREFCNT_dec(PL_lex_stuff);
5794         PL_lex_stuff = Nullsv;
5795         Perl_croak(aTHX_ "Search pattern not terminated");
5796     }
5797
5798     pm = (PMOP*)newPMOP(type, 0);
5799     if (PL_multi_open == '?')
5800         pm->op_pmflags |= PMf_ONCE;
5801     if(type == OP_QR) {
5802         while (*s && strchr("iomsx", *s))
5803             pmflag(&pm->op_pmflags,*s++);
5804     }
5805     else {
5806         while (*s && strchr("iogcmsx", *s))
5807             pmflag(&pm->op_pmflags,*s++);
5808     }
5809     pm->op_pmpermflags = pm->op_pmflags;
5810
5811     PL_lex_op = (OP*)pm;
5812     yylval.ival = OP_MATCH;
5813     return s;
5814 }
5815
5816 STATIC char *
5817 S_scan_subst(pTHX_ char *start)
5818 {
5819     register char *s;
5820     register PMOP *pm;
5821     I32 first_start;
5822     I32 es = 0;
5823
5824     yylval.ival = OP_NULL;
5825
5826     s = scan_str(start,FALSE,FALSE);
5827
5828     if (!s) {
5829         if (PL_lex_stuff)
5830             SvREFCNT_dec(PL_lex_stuff);
5831         PL_lex_stuff = Nullsv;
5832         Perl_croak(aTHX_ "Substitution pattern not terminated");
5833     }
5834
5835     if (s[-1] == PL_multi_open)
5836         s--;
5837
5838     first_start = PL_multi_start;
5839     s = scan_str(s,FALSE,FALSE);
5840     if (!s) {
5841         if (PL_lex_stuff)
5842             SvREFCNT_dec(PL_lex_stuff);
5843         PL_lex_stuff = Nullsv;
5844         if (PL_lex_repl)
5845             SvREFCNT_dec(PL_lex_repl);
5846         PL_lex_repl = Nullsv;
5847         Perl_croak(aTHX_ "Substitution replacement not terminated");
5848     }
5849     PL_multi_start = first_start;       /* so whole substitution is taken together */
5850
5851     pm = (PMOP*)newPMOP(OP_SUBST, 0);
5852     while (*s) {
5853         if (*s == 'e') {
5854             s++;
5855             es++;
5856         }
5857         else if (strchr("iogcmsx", *s))
5858             pmflag(&pm->op_pmflags,*s++);
5859         else
5860             break;
5861     }
5862
5863     if (es) {
5864         SV *repl;
5865         PL_sublex_info.super_bufptr = s;
5866         PL_sublex_info.super_bufend = PL_bufend;
5867         PL_multi_end = 0;
5868         pm->op_pmflags |= PMf_EVAL;
5869         repl = newSVpvn("",0);
5870         while (es-- > 0)
5871             sv_catpv(repl, es ? "eval " : "do ");
5872         sv_catpvn(repl, "{ ", 2);
5873         sv_catsv(repl, PL_lex_repl);
5874         sv_catpvn(repl, " };", 2);
5875         SvEVALED_on(repl);
5876         SvREFCNT_dec(PL_lex_repl);
5877         PL_lex_repl = repl;
5878     }
5879
5880     pm->op_pmpermflags = pm->op_pmflags;
5881     PL_lex_op = (OP*)pm;
5882     yylval.ival = OP_SUBST;
5883     return s;
5884 }
5885
5886 STATIC char *
5887 S_scan_trans(pTHX_ char *start)
5888 {
5889     register char* s;
5890     OP *o;
5891     short *tbl;
5892     I32 squash;
5893     I32 del;
5894     I32 complement;
5895     I32 utf8;
5896     I32 count = 0;
5897
5898     yylval.ival = OP_NULL;
5899
5900     s = scan_str(start,FALSE,FALSE);
5901     if (!s) {
5902         if (PL_lex_stuff)
5903             SvREFCNT_dec(PL_lex_stuff);
5904         PL_lex_stuff = Nullsv;
5905         Perl_croak(aTHX_ "Transliteration pattern not terminated");
5906     }
5907     if (s[-1] == PL_multi_open)
5908         s--;
5909
5910     s = scan_str(s,FALSE,FALSE);
5911     if (!s) {
5912         if (PL_lex_stuff)
5913             SvREFCNT_dec(PL_lex_stuff);
5914         PL_lex_stuff = Nullsv;
5915         if (PL_lex_repl)
5916             SvREFCNT_dec(PL_lex_repl);
5917         PL_lex_repl = Nullsv;
5918         Perl_croak(aTHX_ "Transliteration replacement not terminated");
5919     }
5920
5921     if (UTF) {
5922         o = newSVOP(OP_TRANS, 0, 0);
5923         utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5924     }
5925     else {
5926         New(803,tbl,256,short);
5927         o = newPVOP(OP_TRANS, 0, (char*)tbl);
5928         utf8 = 0;
5929     }
5930
5931     complement = del = squash = 0;
5932     while (strchr("cdsCU", *s)) {
5933         if (*s == 'c')
5934             complement = OPpTRANS_COMPLEMENT;
5935         else if (*s == 'd')
5936             del = OPpTRANS_DELETE;
5937         else if (*s == 's')
5938             squash = OPpTRANS_SQUASH;
5939         else {
5940             switch (count++) {
5941             case 0:
5942                 if (*s == 'C')
5943                     utf8 &= ~OPpTRANS_FROM_UTF;
5944                 else
5945                     utf8 |= OPpTRANS_FROM_UTF;
5946                 break;
5947             case 1:
5948                 if (*s == 'C')
5949                     utf8 &= ~OPpTRANS_TO_UTF;
5950                 else
5951                     utf8 |= OPpTRANS_TO_UTF;
5952                 break;
5953             default:
5954                 Perl_croak(aTHX_ "Too many /C and /U options");
5955             }
5956         }
5957         s++;
5958     }
5959     o->op_private = del|squash|complement|utf8;
5960
5961     PL_lex_op = o;
5962     yylval.ival = OP_TRANS;
5963     return s;
5964 }
5965
5966 STATIC char *
5967 S_scan_heredoc(pTHX_ register char *s)
5968 {
5969     dTHR;
5970     SV *herewas;
5971     I32 op_type = OP_SCALAR;
5972     I32 len;
5973     SV *tmpstr;
5974     char term;
5975     register char *d;
5976     register char *e;
5977     char *peek;
5978     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5979
5980     s += 2;
5981     d = PL_tokenbuf;
5982     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5983     if (!outer)
5984         *d++ = '\n';
5985     for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5986     if (*peek && strchr("`'\"",*peek)) {
5987         s = peek;
5988         term = *s++;
5989         s = delimcpy(d, e, s, PL_bufend, term, &len);
5990         d += len;
5991         if (s < PL_bufend)
5992             s++;
5993     }
5994     else {
5995         if (*s == '\\')
5996             s++, term = '\'';
5997         else
5998             term = '"';
5999         if (!isALNUM_lazy(s))
6000             deprecate("bare << to mean <<\"\"");
6001         for (; isALNUM_lazy(s); s++) {
6002             if (d < e)
6003                 *d++ = *s;
6004         }
6005     }
6006     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6007         Perl_croak(aTHX_ "Delimiter for here document is too long");
6008     *d++ = '\n';
6009     *d = '\0';
6010     len = d - PL_tokenbuf;
6011 #ifndef PERL_STRICT_CR
6012     d = strchr(s, '\r');
6013     if (d) {
6014         char *olds = s;
6015         s = d;
6016         while (s < PL_bufend) {
6017             if (*s == '\r') {
6018                 *d++ = '\n';
6019                 if (*++s == '\n')
6020                     s++;
6021             }
6022             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
6023                 *d++ = *s++;
6024                 s++;
6025             }
6026             else
6027                 *d++ = *s++;
6028         }
6029         *d = '\0';
6030         PL_bufend = d;
6031         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6032         s = olds;
6033     }
6034 #endif
6035     d = "\n";
6036     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6037         herewas = newSVpvn(s,PL_bufend-s);
6038     else
6039         s--, herewas = newSVpvn(s,d-s);
6040     s += SvCUR(herewas);
6041
6042     tmpstr = NEWSV(87,79);
6043     sv_upgrade(tmpstr, SVt_PVIV);
6044     if (term == '\'') {
6045         op_type = OP_CONST;
6046         SvIVX(tmpstr) = -1;
6047     }
6048     else if (term == '`') {
6049         op_type = OP_BACKTICK;
6050         SvIVX(tmpstr) = '\\';
6051     }
6052
6053     CLINE;
6054     PL_multi_start = PL_curcop->cop_line;
6055     PL_multi_open = PL_multi_close = '<';
6056     term = *PL_tokenbuf;
6057     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6058         char *bufptr = PL_sublex_info.super_bufptr;
6059         char *bufend = PL_sublex_info.super_bufend;
6060         char *olds = s - SvCUR(herewas);
6061         s = strchr(bufptr, '\n');
6062         if (!s)
6063             s = bufend;
6064         d = s;
6065         while (s < bufend &&
6066           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6067             if (*s++ == '\n')
6068                 PL_curcop->cop_line++;
6069         }
6070         if (s >= bufend) {
6071             PL_curcop->cop_line = PL_multi_start;
6072             missingterm(PL_tokenbuf);
6073         }
6074         sv_setpvn(herewas,bufptr,d-bufptr+1);
6075         sv_setpvn(tmpstr,d+1,s-d);
6076         s += len - 1;
6077         sv_catpvn(herewas,s,bufend-s);
6078         (void)strcpy(bufptr,SvPVX(herewas));
6079
6080         s = olds;
6081         goto retval;
6082     }
6083     else if (!outer) {
6084         d = s;
6085         while (s < PL_bufend &&
6086           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6087             if (*s++ == '\n')
6088                 PL_curcop->cop_line++;
6089         }
6090         if (s >= PL_bufend) {
6091             PL_curcop->cop_line = PL_multi_start;
6092             missingterm(PL_tokenbuf);
6093         }
6094         sv_setpvn(tmpstr,d+1,s-d);
6095         s += len - 1;
6096         PL_curcop->cop_line++;  /* the preceding stmt passes a newline */
6097
6098         sv_catpvn(herewas,s,PL_bufend-s);
6099         sv_setsv(PL_linestr,herewas);
6100         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6101         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6102     }
6103     else
6104         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
6105     while (s >= PL_bufend) {    /* multiple line string? */
6106         if (!outer ||
6107          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6108             PL_curcop->cop_line = PL_multi_start;
6109             missingterm(PL_tokenbuf);
6110         }
6111         PL_curcop->cop_line++;
6112         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6113 #ifndef PERL_STRICT_CR
6114         if (PL_bufend - PL_linestart >= 2) {
6115             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6116                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6117             {
6118                 PL_bufend[-2] = '\n';
6119                 PL_bufend--;
6120                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6121             }
6122             else if (PL_bufend[-1] == '\r')
6123                 PL_bufend[-1] = '\n';
6124         }
6125         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6126             PL_bufend[-1] = '\n';
6127 #endif
6128         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6129             SV *sv = NEWSV(88,0);
6130
6131             sv_upgrade(sv, SVt_PVMG);
6132             sv_setsv(sv,PL_linestr);
6133             av_store(GvAV(PL_curcop->cop_filegv),
6134               (I32)PL_curcop->cop_line,sv);
6135         }
6136         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6137             s = PL_bufend - 1;
6138             *s = ' ';
6139             sv_catsv(PL_linestr,herewas);
6140             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6141         }
6142         else {
6143             s = PL_bufend;
6144             sv_catsv(tmpstr,PL_linestr);
6145         }
6146     }
6147     s++;
6148 retval:
6149     PL_multi_end = PL_curcop->cop_line;
6150     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6151         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6152         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6153     }
6154     SvREFCNT_dec(herewas);
6155     PL_lex_stuff = tmpstr;
6156     yylval.ival = op_type;
6157     return s;
6158 }
6159
6160 /* scan_inputsymbol
6161    takes: current position in input buffer
6162    returns: new position in input buffer
6163    side-effects: yylval and lex_op are set.
6164
6165    This code handles:
6166
6167    <>           read from ARGV
6168    <FH>         read from filehandle
6169    <pkg::FH>    read from package qualified filehandle
6170    <pkg'FH>     read from package qualified filehandle
6171    <$fh>        read from filehandle in $fh
6172    <*.h>        filename glob
6173
6174 */
6175
6176 STATIC char *
6177 S_scan_inputsymbol(pTHX_ char *start)
6178 {
6179     register char *s = start;           /* current position in buffer */
6180     register char *d;
6181     register char *e;
6182     char *end;
6183     I32 len;
6184
6185     d = PL_tokenbuf;                    /* start of temp holding space */
6186     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
6187     end = strchr(s, '\n');
6188     if (!end)
6189         end = PL_bufend;
6190     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
6191
6192     /* die if we didn't have space for the contents of the <>,
6193        or if it didn't end, or if we see a newline
6194     */
6195
6196     if (len >= sizeof PL_tokenbuf)
6197         Perl_croak(aTHX_ "Excessively long <> operator");
6198     if (s >= end)
6199         Perl_croak(aTHX_ "Unterminated <> operator");
6200
6201     s++;
6202
6203     /* check for <$fh>
6204        Remember, only scalar variables are interpreted as filehandles by
6205        this code.  Anything more complex (e.g., <$fh{$num}>) will be
6206        treated as a glob() call.
6207        This code makes use of the fact that except for the $ at the front,
6208        a scalar variable and a filehandle look the same.
6209     */
6210     if (*d == '$' && d[1]) d++;
6211
6212     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6213     while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
6214         d++;
6215
6216     /* If we've tried to read what we allow filehandles to look like, and
6217        there's still text left, then it must be a glob() and not a getline.
6218        Use scan_str to pull out the stuff between the <> and treat it
6219        as nothing more than a string.
6220     */
6221
6222     if (d - PL_tokenbuf != len) {
6223         yylval.ival = OP_GLOB;
6224         set_csh();
6225         s = scan_str(start,FALSE,FALSE);
6226         if (!s)
6227            Perl_croak(aTHX_ "Glob not terminated");
6228         return s;
6229     }
6230     else {
6231         /* we're in a filehandle read situation */
6232         d = PL_tokenbuf;
6233
6234         /* turn <> into <ARGV> */
6235         if (!len)
6236             (void)strcpy(d,"ARGV");
6237
6238         /* if <$fh>, create the ops to turn the variable into a
6239            filehandle
6240         */
6241         if (*d == '$') {
6242             I32 tmp;
6243
6244             /* try to find it in the pad for this block, otherwise find
6245                add symbol table ops
6246             */
6247             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6248                 OP *o = newOP(OP_PADSV, 0);
6249                 o->op_targ = tmp;
6250                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6251             }
6252             else {
6253                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6254                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6255                                             newUNOP(OP_RV2SV, 0,
6256                                                 newGVOP(OP_GV, 0, gv)));
6257             }
6258             PL_lex_op->op_flags |= OPf_SPECIAL;
6259             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6260             yylval.ival = OP_NULL;
6261         }
6262
6263         /* If it's none of the above, it must be a literal filehandle
6264            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6265         else {
6266             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6267             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6268             yylval.ival = OP_NULL;
6269         }
6270     }
6271
6272     return s;
6273 }
6274
6275
6276 /* scan_str
6277    takes: start position in buffer
6278           keep_quoted preserve \ on the embedded delimiter(s)
6279           keep_delims preserve the delimiters around the string
6280    returns: position to continue reading from buffer
6281    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6282         updates the read buffer.
6283
6284    This subroutine pulls a string out of the input.  It is called for:
6285         q               single quotes           q(literal text)
6286         '               single quotes           'literal text'
6287         qq              double quotes           qq(interpolate $here please)
6288         "               double quotes           "interpolate $here please"
6289         qx              backticks               qx(/bin/ls -l)
6290         `               backticks               `/bin/ls -l`
6291         qw              quote words             @EXPORT_OK = qw( func() $spam )
6292         m//             regexp match            m/this/
6293         s///            regexp substitute       s/this/that/
6294         tr///           string transliterate    tr/this/that/
6295         y///            string transliterate    y/this/that/
6296         ($*@)           sub prototypes          sub foo ($)
6297         (stuff)         sub attr parameters     sub foo : attr(stuff)
6298         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6299
6300    In most of these cases (all but <>, patterns and transliterate)
6301    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6302    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6303    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6304    calls scan_str().
6305
6306    It skips whitespace before the string starts, and treats the first
6307    character as the delimiter.  If the delimiter is one of ([{< then
6308    the corresponding "close" character )]}> is used as the closing
6309    delimiter.  It allows quoting of delimiters, and if the string has
6310    balanced delimiters ([{<>}]) it allows nesting.
6311
6312    The lexer always reads these strings into lex_stuff, except in the
6313    case of the operators which take *two* arguments (s/// and tr///)
6314    when it checks to see if lex_stuff is full (presumably with the 1st
6315    arg to s or tr) and if so puts the string into lex_repl.
6316
6317 */
6318
6319 STATIC char *
6320 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6321 {
6322     dTHR;
6323     SV *sv;                             /* scalar value: string */
6324     char *tmps;                         /* temp string, used for delimiter matching */
6325     register char *s = start;           /* current position in the buffer */
6326     register char term;                 /* terminating character */
6327     register char *to;                  /* current position in the sv's data */
6328     I32 brackets = 1;                   /* bracket nesting level */
6329
6330     /* skip space before the delimiter */
6331     if (isSPACE(*s))
6332         s = skipspace(s);
6333
6334     /* mark where we are, in case we need to report errors */
6335     CLINE;
6336
6337     /* after skipping whitespace, the next character is the terminator */
6338     term = *s;
6339     /* mark where we are */
6340     PL_multi_start = PL_curcop->cop_line;
6341     PL_multi_open = term;
6342
6343     /* find corresponding closing delimiter */
6344     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6345         term = tmps[5];
6346     PL_multi_close = term;
6347
6348     /* create a new SV to hold the contents.  87 is leak category, I'm
6349        assuming.  79 is the SV's initial length.  What a random number. */
6350     sv = NEWSV(87,79);
6351     sv_upgrade(sv, SVt_PVIV);
6352     SvIVX(sv) = term;
6353     (void)SvPOK_only(sv);               /* validate pointer */
6354
6355     /* move past delimiter and try to read a complete string */
6356     if (keep_delims)
6357         sv_catpvn(sv, s, 1);
6358     s++;
6359     for (;;) {
6360         /* extend sv if need be */
6361         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6362         /* set 'to' to the next character in the sv's string */
6363         to = SvPVX(sv)+SvCUR(sv);
6364
6365         /* if open delimiter is the close delimiter read unbridle */
6366         if (PL_multi_open == PL_multi_close) {
6367             for (; s < PL_bufend; s++,to++) {
6368                 /* embedded newlines increment the current line number */
6369                 if (*s == '\n' && !PL_rsfp)
6370                     PL_curcop->cop_line++;
6371                 /* handle quoted delimiters */
6372                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6373                     if (!keep_quoted && s[1] == term)
6374                         s++;
6375                 /* any other quotes are simply copied straight through */
6376                     else
6377                         *to++ = *s++;
6378                 }
6379                 /* terminate when run out of buffer (the for() condition), or
6380                    have found the terminator */
6381                 else if (*s == term)
6382                     break;
6383                 *to = *s;
6384             }
6385         }
6386
6387         /* if the terminator isn't the same as the start character (e.g.,
6388            matched brackets), we have to allow more in the quoting, and
6389            be prepared for nested brackets.
6390         */
6391         else {
6392             /* read until we run out of string, or we find the terminator */
6393             for (; s < PL_bufend; s++,to++) {
6394                 /* embedded newlines increment the line count */
6395                 if (*s == '\n' && !PL_rsfp)
6396                     PL_curcop->cop_line++;
6397                 /* backslashes can escape the open or closing characters */
6398                 if (*s == '\\' && s+1 < PL_bufend) {
6399                     if (!keep_quoted &&
6400                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6401                         s++;
6402                     else
6403                         *to++ = *s++;
6404                 }
6405                 /* allow nested opens and closes */
6406                 else if (*s == PL_multi_close && --brackets <= 0)
6407                     break;
6408                 else if (*s == PL_multi_open)
6409                     brackets++;
6410                 *to = *s;
6411             }
6412         }
6413         /* terminate the copied string and update the sv's end-of-string */
6414         *to = '\0';
6415         SvCUR_set(sv, to - SvPVX(sv));
6416
6417         /*
6418          * this next chunk reads more into the buffer if we're not done yet
6419          */
6420
6421         if (s < PL_bufend) break;       /* handle case where we are done yet :-) */
6422
6423 #ifndef PERL_STRICT_CR
6424         if (to - SvPVX(sv) >= 2) {
6425             if ((to[-2] == '\r' && to[-1] == '\n') ||
6426                 (to[-2] == '\n' && to[-1] == '\r'))
6427             {
6428                 to[-2] = '\n';
6429                 to--;
6430                 SvCUR_set(sv, to - SvPVX(sv));
6431             }
6432             else if (to[-1] == '\r')
6433                 to[-1] = '\n';
6434         }
6435         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6436             to[-1] = '\n';
6437 #endif
6438
6439         /* if we're out of file, or a read fails, bail and reset the current
6440            line marker so we can report where the unterminated string began
6441         */
6442         if (!PL_rsfp ||
6443          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6444             sv_free(sv);
6445             PL_curcop->cop_line = PL_multi_start;
6446             return Nullch;
6447         }
6448         /* we read a line, so increment our line counter */
6449         PL_curcop->cop_line++;
6450
6451         /* update debugger info */
6452         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6453             SV *sv = NEWSV(88,0);
6454
6455             sv_upgrade(sv, SVt_PVMG);
6456             sv_setsv(sv,PL_linestr);
6457             av_store(GvAV(PL_curcop->cop_filegv),
6458               (I32)PL_curcop->cop_line, sv);
6459         }
6460
6461         /* having changed the buffer, we must update PL_bufend */
6462         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6463     }
6464
6465     /* at this point, we have successfully read the delimited string */
6466
6467     if (keep_delims)
6468         sv_catpvn(sv, s, 1);
6469     PL_multi_end = PL_curcop->cop_line;
6470     s++;
6471
6472     /* if we allocated too much space, give some back */
6473     if (SvCUR(sv) + 5 < SvLEN(sv)) {
6474         SvLEN_set(sv, SvCUR(sv) + 1);
6475         Renew(SvPVX(sv), SvLEN(sv), char);
6476     }
6477
6478     /* decide whether this is the first or second quoted string we've read
6479        for this op
6480     */
6481
6482     if (PL_lex_stuff)
6483         PL_lex_repl = sv;
6484     else
6485         PL_lex_stuff = sv;
6486     return s;
6487 }
6488
6489 /*
6490   scan_num
6491   takes: pointer to position in buffer
6492   returns: pointer to new position in buffer
6493   side-effects: builds ops for the constant in yylval.op
6494
6495   Read a number in any of the formats that Perl accepts:
6496
6497   0(x[0-7A-F]+)|([0-7]+)|(b[01])
6498   [\d_]+(\.[\d_]*)?[Ee](\d+)
6499
6500   Underbars (_) are allowed in decimal numbers.  If -w is on,
6501   underbars before a decimal point must be at three digit intervals.
6502
6503   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6504   thing it reads.
6505
6506   If it reads a number without a decimal point or an exponent, it will
6507   try converting the number to an integer and see if it can do so
6508   without loss of precision.
6509 */
6510
6511 char *
6512 Perl_scan_num(pTHX_ char *start)
6513 {
6514     register char *s = start;           /* current position in buffer */
6515     register char *d;                   /* destination in temp buffer */
6516     register char *e;                   /* end of temp buffer */
6517     IV tryiv;                           /* used to see if it can be an IV */
6518     NV value;                           /* number read, as a double */
6519     SV *sv;                             /* place to put the converted number */
6520     bool floatit;                       /* boolean: int or float? */
6521     char *lastub = 0;                   /* position of last underbar */
6522     static char number_too_long[] = "Number too long";
6523
6524     /* We use the first character to decide what type of number this is */
6525
6526     switch (*s) {
6527     default:
6528       Perl_croak(aTHX_ "panic: scan_num");
6529
6530     /* if it starts with a 0, it could be an octal number, a decimal in
6531        0.13 disguise, or a hexadecimal number, or a binary number.
6532     */
6533     case '0':
6534         {
6535           /* variables:
6536              u          holds the "number so far"
6537              shift      the power of 2 of the base
6538                         (hex == 4, octal == 3, binary == 1)
6539              overflowed was the number more than we can hold?
6540
6541              Shift is used when we add a digit.  It also serves as an "are
6542              we in octal/hex/binary?" indicator to disallow hex characters
6543              when in octal mode.
6544            */
6545             dTHR;
6546             NV n = 0.0;
6547             UV u = 0;
6548             I32 shift;
6549             bool overflowed = FALSE;
6550             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6551             static char* bases[5] = { "", "binary", "", "octal",
6552                                       "hexadecimal" };
6553             static char* Bases[5] = { "", "Binary", "", "Octal",
6554                                       "Hexadecimal" };
6555             static char *maxima[5] = { "",
6556                                        "0b11111111111111111111111111111111",
6557                                        "",
6558                                        "037777777777",
6559                                        "0xffffffff" };
6560             char *base, *Base, *max;
6561
6562             /* check for hex */
6563             if (s[1] == 'x') {
6564                 shift = 4;
6565                 s += 2;
6566             } else if (s[1] == 'b') {
6567                 shift = 1;
6568                 s += 2;
6569             }
6570             /* check for a decimal in disguise */
6571             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6572                 goto decimal;
6573             /* so it must be octal */
6574             else
6575                 shift = 3;
6576
6577             base = bases[shift];
6578             Base = Bases[shift];
6579             max  = maxima[shift];
6580
6581             /* read the rest of the number */
6582             for (;;) {
6583                 /* x is used in the overflow test,
6584                    b is the digit we're adding on. */
6585                 UV x, b;
6586
6587                 switch (*s) {
6588
6589                 /* if we don't mention it, we're done */
6590                 default:
6591                     goto out;
6592
6593                 /* _ are ignored */
6594                 case '_':
6595                     s++;
6596                     break;
6597
6598                 /* 8 and 9 are not octal */
6599                 case '8': case '9':
6600                     if (shift == 3)
6601                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6602                     /* FALL THROUGH */
6603
6604                 /* octal digits */
6605                 case '2': case '3': case '4':
6606                 case '5': case '6': case '7':
6607                     if (shift == 1)
6608                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6609                     /* FALL THROUGH */
6610
6611                 case '0': case '1':
6612                     b = *s++ & 15;              /* ASCII digit -> value of digit */
6613                     goto digit;
6614
6615                 /* hex digits */
6616                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6617                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6618                     /* make sure they said 0x */
6619                     if (shift != 4)
6620                         goto out;
6621                     b = (*s++ & 7) + 9;
6622
6623                     /* Prepare to put the digit we have onto the end
6624                        of the number so far.  We check for overflows.
6625                     */
6626
6627                   digit:
6628                     if (!overflowed) {
6629                         x = u << shift; /* make room for the digit */
6630
6631                         if ((x >> shift) != u
6632                             && !(PL_hints & HINT_NEW_BINARY)) {
6633                             dTHR;
6634                             overflowed = TRUE;
6635                             n = (NV) u;
6636                             if (ckWARN_d(WARN_OVERFLOW))
6637                                 Perl_warner(aTHX_ WARN_OVERFLOW,
6638                                             "Integer overflow in %s number",
6639                                             base);
6640                         } else
6641                             u = x | b;          /* add the digit to the end */
6642                     }
6643                     if (overflowed) {
6644                         n *= nvshift[shift];
6645                         /* If an NV has not enough bits in its
6646                          * mantissa to represent an UV this summing of
6647                          * small low-order numbers is a waste of time
6648                          * (because the NV cannot preserve the
6649                          * low-order bits anyway): we could just
6650                          * remember when did we overflow and in the
6651                          * end just multiply n by the right
6652                          * amount. */
6653                         n += (NV) b;
6654                     }
6655                     break;
6656                 }
6657             }
6658
6659           /* if we get here, we had success: make a scalar value from
6660              the number.
6661           */
6662           out:
6663             sv = NEWSV(92,0);
6664             if (overflowed) {
6665                 dTHR;
6666                 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6667                     Perl_warner(aTHX_ WARN_PORTABLE,
6668                                 "%s number > %s non-portable",
6669                                 Base, max);
6670                 sv_setnv(sv, n);
6671             }
6672             else {
6673 #if UVSIZE > 4
6674                 dTHR;
6675                 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6676                     Perl_warner(aTHX_ WARN_PORTABLE,
6677                                 "%s number > %s non-portable",
6678                                 Base, max);
6679 #endif
6680                 sv_setuv(sv, u);
6681             }
6682             if (PL_hints & HINT_NEW_BINARY)
6683                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6684         }
6685         break;
6686
6687     /*
6688       handle decimal numbers.
6689       we're also sent here when we read a 0 as the first digit
6690     */
6691     case '1': case '2': case '3': case '4': case '5':
6692     case '6': case '7': case '8': case '9': case '.':
6693       decimal:
6694         d = PL_tokenbuf;
6695         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6696         floatit = FALSE;
6697
6698         /* read next group of digits and _ and copy into d */
6699         while (isDIGIT(*s) || *s == '_') {
6700             /* skip underscores, checking for misplaced ones
6701                if -w is on
6702             */
6703             if (*s == '_') {
6704                 dTHR;                   /* only for ckWARN */
6705                 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6706                     Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6707                 lastub = ++s;
6708             }
6709             else {
6710                 /* check for end of fixed-length buffer */
6711                 if (d >= e)
6712                     Perl_croak(aTHX_ number_too_long);
6713                 /* if we're ok, copy the character */
6714                 *d++ = *s++;
6715             }
6716         }
6717
6718         /* final misplaced underbar check */
6719         if (lastub && s - lastub != 3) {
6720             dTHR;
6721             if (ckWARN(WARN_SYNTAX))
6722                 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6723         }
6724
6725         /* read a decimal portion if there is one.  avoid
6726            3..5 being interpreted as the number 3. followed
6727            by .5
6728         */
6729         if (*s == '.' && s[1] != '.') {
6730             floatit = TRUE;
6731             *d++ = *s++;
6732
6733             /* copy, ignoring underbars, until we run out of
6734                digits.  Note: no misplaced underbar checks!
6735             */
6736             for (; isDIGIT(*s) || *s == '_'; s++) {
6737                 /* fixed length buffer check */
6738                 if (d >= e)
6739                     Perl_croak(aTHX_ number_too_long);
6740                 if (*s != '_')
6741                     *d++ = *s;
6742             }
6743         }
6744
6745         /* read exponent part, if present */
6746         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6747             floatit = TRUE;
6748             s++;
6749
6750             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6751             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
6752
6753             /* allow positive or negative exponent */
6754             if (*s == '+' || *s == '-')
6755                 *d++ = *s++;
6756
6757             /* read digits of exponent (no underbars :-) */
6758             while (isDIGIT(*s)) {
6759                 if (d >= e)
6760                     Perl_croak(aTHX_ number_too_long);
6761                 *d++ = *s++;
6762             }
6763         }
6764
6765         /* terminate the string */
6766         *d = '\0';
6767
6768         /* make an sv from the string */
6769         sv = NEWSV(92,0);
6770
6771         value = Atof(PL_tokenbuf);
6772
6773         /*
6774            See if we can make do with an integer value without loss of
6775            precision.  We use I_V to cast to an int, because some
6776            compilers have issues.  Then we try casting it back and see
6777            if it was the same.  We only do this if we know we
6778            specifically read an integer.
6779
6780            Note: if floatit is true, then we don't need to do the
6781            conversion at all.
6782         */
6783         tryiv = I_V(value);
6784         if (!floatit && (NV)tryiv == value)
6785             sv_setiv(sv, tryiv);
6786         else
6787             sv_setnv(sv, value);
6788         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6789                        (PL_hints & HINT_NEW_INTEGER) )
6790             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6791                               (floatit ? "float" : "integer"),
6792                               sv, Nullsv, NULL);
6793         break;
6794     }
6795
6796     /* make the op for the constant and return */
6797
6798     yylval.opval = newSVOP(OP_CONST, 0, sv);
6799
6800     return s;
6801 }
6802
6803 STATIC char *
6804 S_scan_formline(pTHX_ register char *s)
6805 {
6806     dTHR;
6807     register char *eol;
6808     register char *t;
6809     SV *stuff = newSVpvn("",0);
6810     bool needargs = FALSE;
6811
6812     while (!needargs) {
6813         if (*s == '.' || *s == '}') {
6814             /*SUPPRESS 530*/
6815 #ifdef PERL_STRICT_CR
6816             for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6817 #else
6818             for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6819 #endif
6820             if (*t == '\n' || t == PL_bufend)
6821                 break;
6822         }
6823         if (PL_in_eval && !PL_rsfp) {
6824             eol = strchr(s,'\n');
6825             if (!eol++)
6826                 eol = PL_bufend;
6827         }
6828         else
6829             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6830         if (*s != '#') {
6831             for (t = s; t < eol; t++) {
6832                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6833                     needargs = FALSE;
6834                     goto enough;        /* ~~ must be first line in formline */
6835                 }
6836                 if (*t == '@' || *t == '^')
6837                     needargs = TRUE;
6838             }
6839             sv_catpvn(stuff, s, eol-s);
6840         }
6841         s = eol;
6842         if (PL_rsfp) {
6843             s = filter_gets(PL_linestr, PL_rsfp, 0);
6844             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6845             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6846             if (!s) {
6847                 s = PL_bufptr;
6848                 yyerror("Format not terminated");
6849                 break;
6850             }
6851         }
6852         incline(s);
6853     }
6854   enough:
6855     if (SvCUR(stuff)) {
6856         PL_expect = XTERM;
6857         if (needargs) {
6858             PL_lex_state = LEX_NORMAL;
6859             PL_nextval[PL_nexttoke].ival = 0;
6860             force_next(',');
6861         }
6862         else
6863             PL_lex_state = LEX_FORMLINE;
6864         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6865         force_next(THING);
6866         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6867         force_next(LSTOP);
6868     }
6869     else {
6870         SvREFCNT_dec(stuff);
6871         PL_lex_formbrack = 0;
6872         PL_bufptr = s;
6873     }
6874     return s;
6875 }
6876
6877 STATIC void
6878 S_set_csh(pTHX)
6879 {
6880 #ifdef CSH
6881     if (!PL_cshlen)
6882         PL_cshlen = strlen(PL_cshname);
6883 #endif
6884 }
6885
6886 I32
6887 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6888 {
6889     dTHR;
6890     I32 oldsavestack_ix = PL_savestack_ix;
6891     CV* outsidecv = PL_compcv;
6892     AV* comppadlist;
6893
6894     if (PL_compcv) {
6895         assert(SvTYPE(PL_compcv) == SVt_PVCV);
6896     }
6897     save_I32(&PL_subline);
6898     save_item(PL_subname);
6899     SAVEI32(PL_padix);
6900     SAVESPTR(PL_curpad);
6901     SAVESPTR(PL_comppad);
6902     SAVESPTR(PL_comppad_name);
6903     SAVESPTR(PL_compcv);
6904     SAVEI32(PL_comppad_name_fill);
6905     SAVEI32(PL_min_intro_pending);
6906     SAVEI32(PL_max_intro_pending);
6907     SAVEI32(PL_pad_reset_pending);
6908
6909     PL_compcv = (CV*)NEWSV(1104,0);
6910     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6911     CvFLAGS(PL_compcv) |= flags;
6912
6913     PL_comppad = newAV();
6914     av_push(PL_comppad, Nullsv);
6915     PL_curpad = AvARRAY(PL_comppad);
6916     PL_comppad_name = newAV();
6917     PL_comppad_name_fill = 0;
6918     PL_min_intro_pending = 0;
6919     PL_padix = 0;
6920     PL_subline = PL_curcop->cop_line;
6921 #ifdef USE_THREADS
6922     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6923     PL_curpad[0] = (SV*)newAV();
6924     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
6925 #endif /* USE_THREADS */
6926
6927     comppadlist = newAV();
6928     AvREAL_off(comppadlist);
6929     av_store(comppadlist, 0, (SV*)PL_comppad_name);
6930     av_store(comppadlist, 1, (SV*)PL_comppad);
6931
6932     CvPADLIST(PL_compcv) = comppadlist;
6933     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6934 #ifdef USE_THREADS
6935     CvOWNER(PL_compcv) = 0;
6936     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6937     MUTEX_INIT(CvMUTEXP(PL_compcv));
6938 #endif /* USE_THREADS */
6939
6940     return oldsavestack_ix;
6941 }
6942
6943 int
6944 Perl_yywarn(pTHX_ char *s)
6945 {
6946     dTHR;
6947     PL_in_eval |= EVAL_WARNONLY;
6948     yyerror(s);
6949     PL_in_eval &= ~EVAL_WARNONLY;
6950     return 0;
6951 }
6952
6953 int
6954 Perl_yyerror(pTHX_ char *s)
6955 {
6956     dTHR;
6957     char *where = NULL;
6958     char *context = NULL;
6959     int contlen = -1;
6960     SV *msg;
6961
6962     if (!yychar || (yychar == ';' && !PL_rsfp))
6963         where = "at EOF";
6964     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6965       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6966         while (isSPACE(*PL_oldoldbufptr))
6967             PL_oldoldbufptr++;
6968         context = PL_oldoldbufptr;
6969         contlen = PL_bufptr - PL_oldoldbufptr;
6970     }
6971     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6972       PL_oldbufptr != PL_bufptr) {
6973         while (isSPACE(*PL_oldbufptr))
6974             PL_oldbufptr++;
6975         context = PL_oldbufptr;
6976         contlen = PL_bufptr - PL_oldbufptr;
6977     }
6978     else if (yychar > 255)
6979         where = "next token ???";
6980     else if ((yychar & 127) == 127) {
6981         if (PL_lex_state == LEX_NORMAL ||
6982            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6983             where = "at end of line";
6984         else if (PL_lex_inpat)
6985             where = "within pattern";
6986         else
6987             where = "within string";
6988     }
6989     else {
6990         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6991         if (yychar < 32)
6992             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6993         else if (isPRINT_LC(yychar))
6994             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6995         else
6996             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6997         where = SvPVX(where_sv);
6998     }
6999     msg = sv_2mortal(newSVpv(s, 0));
7000 #ifdef IV_IS_QUAD
7001     Perl_sv_catpvf(aTHX_ msg, " at %_ line %" PERL_PRId64 ", ",
7002               GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line);
7003 #else
7004     Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
7005               GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
7006 #endif
7007     if (context)
7008         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7009     else
7010         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7011     if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
7012 #ifdef IV_IS_QUAD
7013         Perl_sv_catpvf(aTHX_ msg,
7014         "  (Might be a runaway multi-line %c%c string starting on line %" PERL_\
7015 PRId64 ")\n",
7016                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7017 #else
7018         Perl_sv_catpvf(aTHX_ msg,
7019         "  (Might be a runaway multi-line %c%c string starting on line %ld)\n",
7020                 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
7021 #endif
7022         PL_multi_end = 0;
7023     }
7024     if (PL_in_eval & EVAL_WARNONLY)
7025         Perl_warn(aTHX_ "%_", msg);
7026     else
7027         qerror(msg);
7028     if (PL_error_count >= 10)
7029         Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
7030     PL_in_my = 0;
7031     PL_in_my_stash = Nullhv;
7032     return 0;
7033 }
7034
7035
7036 #ifdef PERL_OBJECT
7037 #define NO_XSLOCKS
7038 #include "XSUB.h"
7039 #endif
7040
7041 /*
7042  * restore_rsfp
7043  * Restore a source filter.
7044  */
7045
7046 static void
7047 restore_rsfp(pTHXo_ void *f)
7048 {
7049     PerlIO *fp = (PerlIO*)f;
7050
7051     if (PL_rsfp == PerlIO_stdin())
7052         PerlIO_clearerr(PL_rsfp);
7053     else if (PL_rsfp && (PL_rsfp != fp))
7054         PerlIO_close(PL_rsfp);
7055     PL_rsfp = fp;
7056 }
7057
7058 /*
7059  * restore_expect
7060  * Restores the state of PL_expect when the lexing that begun with a
7061  * start_lex() call has ended.
7062  */
7063
7064 static void
7065 restore_expect(pTHXo_ void *e)
7066 {
7067     /* a safe way to store a small integer in a pointer */
7068     PL_expect = (expectation)((char *)e - PL_tokenbuf);
7069 }
7070
7071 /*
7072  * restore_lex_expect
7073  * Restores the state of PL_lex_expect when the lexing that begun with a
7074  * start_lex() call has ended.
7075  */
7076
7077 static void
7078 restore_lex_expect(pTHXo_ void *e)
7079 {
7080     /* a safe way to store a small integer in a pointer */
7081     PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
7082 }