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