toke.c

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