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         why2 = strEQ(key,"charnames")
5753                ? "(possibly a missing \"use charnames ...\")"
5754                : "";
5755         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5756                             (type ? type: "undef"), why2);
5757
5758         /* This is convoluted and evil ("goto considered harmful")
5759          * but I do not understand the intricacies of all the different
5760          * failure modes of %^H in here.  The goal here is to make
5761          * the most probable error message user-friendly. --jhi */
5762
5763         goto msgdone;
5764
5765     report:
5766         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5767                             (type ? type: "undef"), why1, why2, why3);
5768     msgdone:
5769         yyerror(SvPVX(msg));
5770         SvREFCNT_dec(msg);
5771         return sv;
5772     }
5773     cvp = hv_fetch(table, key, strlen(key), FALSE);
5774     if (!cvp || !SvOK(*cvp)) {
5775         why1 = "$^H{";
5776         why2 = key;
5777         why3 = "} is not defined";
5778         goto report;
5779     }
5780     sv_2mortal(sv);                     /* Parent created it permanently */
5781     cv = *cvp;
5782     if (!pv && s)
5783         pv = sv_2mortal(newSVpvn(s, len));
5784     if (type && pv)
5785         typesv = sv_2mortal(newSVpv(type, 0));
5786     else
5787         typesv = &PL_sv_undef;
5788
5789     PUSHSTACKi(PERLSI_OVERLOAD);
5790     ENTER ;
5791     SAVETMPS;
5792
5793     PUSHMARK(SP) ;
5794     EXTEND(sp, 3);
5795     if (pv)
5796         PUSHs(pv);
5797     PUSHs(sv);
5798     if (pv)
5799         PUSHs(typesv);
5800     PUTBACK;
5801     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5802
5803     SPAGAIN ;
5804
5805     /* Check the eval first */
5806     if (!PL_in_eval && SvTRUE(ERRSV)) {
5807         STRLEN n_a;
5808         sv_catpv(ERRSV, "Propagated");
5809         yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5810         (void)POPs;
5811         res = SvREFCNT_inc(sv);
5812     }
5813     else {
5814         res = POPs;
5815         (void)SvREFCNT_inc(res);
5816     }
5817
5818     PUTBACK ;
5819     FREETMPS ;
5820     LEAVE ;
5821     POPSTACK;
5822
5823     if (!SvOK(res)) {
5824         why1 = "Call to &{$^H{";
5825         why2 = key;
5826         why3 = "}} did not return a defined value";
5827         sv = res;
5828         goto report;
5829     }
5830
5831     return res;
5832 }
5833
5834 STATIC char *
5835 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5836 {
5837     register char *d = dest;
5838     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
5839     for (;;) {
5840         if (d >= e)
5841             Perl_croak(aTHX_ ident_too_long);
5842         if (isALNUM(*s))        /* UTF handled below */
5843             *d++ = *s++;
5844         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5845             *d++ = ':';
5846             *d++ = ':';
5847             s++;
5848         }
5849         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5850             *d++ = *s++;
5851             *d++ = *s++;
5852         }
5853         else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5854             char *t = s + UTF8SKIP(s);
5855             while (*t & 0x80 && is_utf8_mark((U8*)t))
5856                 t += UTF8SKIP(t);
5857             if (d + (t - s) > e)
5858                 Perl_croak(aTHX_ ident_too_long);
5859             Copy(s, d, t - s, char);
5860             d += t - s;
5861             s = t;
5862         }
5863         else {
5864             *d = '\0';
5865             *slp = d - dest;
5866             return s;
5867         }
5868     }
5869 }
5870
5871 STATIC char *
5872 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5873 {
5874     register char *d;
5875     register char *e;
5876     char *bracket = 0;
5877     char funny = *s++;
5878
5879     if (isSPACE(*s))
5880         s = skipspace(s);
5881     d = dest;
5882     e = d + destlen - 3;        /* two-character token, ending NUL */
5883     if (isDIGIT(*s)) {
5884         while (isDIGIT(*s)) {
5885             if (d >= e)
5886                 Perl_croak(aTHX_ ident_too_long);
5887             *d++ = *s++;
5888         }
5889     }
5890     else {
5891         for (;;) {
5892             if (d >= e)
5893                 Perl_croak(aTHX_ ident_too_long);
5894             if (isALNUM(*s))    /* UTF handled below */
5895                 *d++ = *s++;
5896             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5897                 *d++ = ':';
5898                 *d++ = ':';
5899                 s++;
5900             }
5901             else if (*s == ':' && s[1] == ':') {
5902                 *d++ = *s++;
5903                 *d++ = *s++;
5904             }
5905             else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5906                 char *t = s + UTF8SKIP(s);
5907                 while (*t & 0x80 && is_utf8_mark((U8*)t))
5908                     t += UTF8SKIP(t);
5909                 if (d + (t - s) > e)
5910                     Perl_croak(aTHX_ ident_too_long);
5911                 Copy(s, d, t - s, char);
5912                 d += t - s;
5913                 s = t;
5914             }
5915             else
5916                 break;
5917         }
5918     }
5919     *d = '\0';
5920     d = dest;
5921     if (*d) {
5922         if (PL_lex_state != LEX_NORMAL)
5923             PL_lex_state = LEX_INTERPENDMAYBE;
5924         return s;
5925     }
5926     if (*s == '$' && s[1] &&
5927         (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5928     {
5929         return s;
5930     }
5931     if (*s == '{') {
5932         bracket = s;
5933         s++;
5934     }
5935     else if (ck_uni)
5936         check_uni();
5937     if (s < send)
5938         *d = *s++;
5939     d[1] = '\0';
5940     if (*d == '^' && *s && isCONTROLVAR(*s)) {
5941         *d = toCTRL(*s);
5942         s++;
5943     }
5944     if (bracket) {
5945         if (isSPACE(s[-1])) {
5946             while (s < send) {
5947                 char ch = *s++;
5948                 if (!SPACE_OR_TAB(ch)) {
5949                     *d = ch;
5950                     break;
5951                 }
5952             }
5953         }
5954         if (isIDFIRST_lazy_if(d,UTF)) {
5955             d++;
5956             if (UTF) {
5957                 e = s;
5958                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
5959                     e += UTF8SKIP(e);
5960                     while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5961                         e += UTF8SKIP(e);
5962                 }
5963                 Copy(s, d, e - s, char);
5964                 d += e - s;
5965                 s = e;
5966             }
5967             else {
5968                 while ((isALNUM(*s) || *s == ':') && d < e)
5969                     *d++ = *s++;
5970                 if (d >= e)
5971                     Perl_croak(aTHX_ ident_too_long);
5972             }
5973             *d = '\0';
5974             while (s < send && SPACE_OR_TAB(*s)) s++;
5975             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5976                 dTHR;                   /* only for ckWARN */
5977                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5978                     const char *brack = *s == '[' ? "[...]" : "{...}";
5979                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
5980                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5981                         funny, dest, brack, funny, dest, brack);
5982                 }
5983                 bracket++;
5984                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5985                 return s;
5986             }
5987         }
5988         /* Handle extended ${^Foo} variables
5989          * 1999-02-27 mjd-perl-patch@plover.com */
5990         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5991                  && isALNUM(*s))
5992         {
5993             d++;
5994             while (isALNUM(*s) && d < e) {
5995                 *d++ = *s++;
5996             }
5997             if (d >= e)
5998                 Perl_croak(aTHX_ ident_too_long);
5999             *d = '\0';
6000         }
6001         if (*s == '}') {
6002             s++;
6003             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6004                 PL_lex_state = LEX_INTERPEND;
6005             if (funny == '#')
6006                 funny = '@';
6007             if (PL_lex_state == LEX_NORMAL) {
6008                 dTHR;                   /* only for ckWARN */
6009                 if (ckWARN(WARN_AMBIGUOUS) &&
6010                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6011                 {
6012                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
6013                         "Ambiguous use of %c{%s} resolved to %c%s",
6014                         funny, dest, funny, dest);
6015                 }
6016             }
6017         }
6018         else {
6019             s = bracket;                /* let the parser handle it */
6020             *dest = '\0';
6021         }
6022     }
6023     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6024         PL_lex_state = LEX_INTERPEND;
6025     return s;
6026 }
6027
6028 void
6029 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6030 {
6031     if (ch == 'i')
6032         *pmfl |= PMf_FOLD;
6033     else if (ch == 'g')
6034         *pmfl |= PMf_GLOBAL;
6035     else if (ch == 'c')
6036         *pmfl |= PMf_CONTINUE;
6037     else if (ch == 'o')
6038         *pmfl |= PMf_KEEP;
6039     else if (ch == 'm')
6040         *pmfl |= PMf_MULTILINE;
6041     else if (ch == 's')
6042         *pmfl |= PMf_SINGLELINE;
6043     else if (ch == 'x')
6044         *pmfl |= PMf_EXTENDED;
6045 }
6046
6047 STATIC char *
6048 S_scan_pat(pTHX_ char *start, I32 type)
6049 {
6050     PMOP *pm;
6051     char *s;
6052
6053     s = scan_str(start,FALSE,FALSE);
6054     if (!s) {
6055         if (PL_lex_stuff)
6056             SvREFCNT_dec(PL_lex_stuff);
6057         PL_lex_stuff = Nullsv;
6058         Perl_croak(aTHX_ "Search pattern not terminated");
6059     }
6060
6061     pm = (PMOP*)newPMOP(type, 0);
6062     if (PL_multi_open == '?')
6063         pm->op_pmflags |= PMf_ONCE;
6064     if(type == OP_QR) {
6065         while (*s && strchr("iomsx", *s))
6066             pmflag(&pm->op_pmflags,*s++);
6067     }
6068     else {
6069         while (*s && strchr("iogcmsx", *s))
6070             pmflag(&pm->op_pmflags,*s++);
6071     }
6072     pm->op_pmpermflags = pm->op_pmflags;
6073
6074     PL_lex_op = (OP*)pm;
6075     yylval.ival = OP_MATCH;
6076     return s;
6077 }
6078
6079 STATIC char *
6080 S_scan_subst(pTHX_ char *start)
6081 {
6082     register char *s;
6083     register PMOP *pm;
6084     I32 first_start;
6085     I32 es = 0;
6086
6087     yylval.ival = OP_NULL;
6088
6089     s = scan_str(start,FALSE,FALSE);
6090
6091     if (!s) {
6092         if (PL_lex_stuff)
6093             SvREFCNT_dec(PL_lex_stuff);
6094         PL_lex_stuff = Nullsv;
6095         Perl_croak(aTHX_ "Substitution pattern not terminated");
6096     }
6097
6098     if (s[-1] == PL_multi_open)
6099         s--;
6100
6101     first_start = PL_multi_start;
6102     s = scan_str(s,FALSE,FALSE);
6103     if (!s) {
6104         if (PL_lex_stuff)
6105             SvREFCNT_dec(PL_lex_stuff);
6106         PL_lex_stuff = Nullsv;
6107         if (PL_lex_repl)
6108             SvREFCNT_dec(PL_lex_repl);
6109         PL_lex_repl = Nullsv;
6110         Perl_croak(aTHX_ "Substitution replacement not terminated");
6111     }
6112     PL_multi_start = first_start;       /* so whole substitution is taken together */
6113
6114     pm = (PMOP*)newPMOP(OP_SUBST, 0);
6115     while (*s) {
6116         if (*s == 'e') {
6117             s++;
6118             es++;
6119         }
6120         else if (strchr("iogcmsx", *s))
6121             pmflag(&pm->op_pmflags,*s++);
6122         else
6123             break;
6124     }
6125
6126     if (es) {
6127         SV *repl;
6128         PL_sublex_info.super_bufptr = s;
6129         PL_sublex_info.super_bufend = PL_bufend;
6130         PL_multi_end = 0;
6131         pm->op_pmflags |= PMf_EVAL;
6132         repl = newSVpvn("",0);
6133         while (es-- > 0)
6134             sv_catpv(repl, es ? "eval " : "do ");
6135         sv_catpvn(repl, "{ ", 2);
6136         sv_catsv(repl, PL_lex_repl);
6137         sv_catpvn(repl, " };", 2);
6138         SvEVALED_on(repl);
6139         SvREFCNT_dec(PL_lex_repl);
6140         PL_lex_repl = repl;
6141     }
6142
6143     pm->op_pmpermflags = pm->op_pmflags;
6144     PL_lex_op = (OP*)pm;
6145     yylval.ival = OP_SUBST;
6146     return s;
6147 }
6148
6149 STATIC char *
6150 S_scan_trans(pTHX_ char *start)
6151 {
6152     register char* s;
6153     OP *o;
6154     short *tbl;
6155     I32 squash;
6156     I32 del;
6157     I32 complement;
6158     I32 utf8;
6159     I32 count = 0;
6160
6161     yylval.ival = OP_NULL;
6162
6163     s = scan_str(start,FALSE,FALSE);
6164     if (!s) {
6165         if (PL_lex_stuff)
6166             SvREFCNT_dec(PL_lex_stuff);
6167         PL_lex_stuff = Nullsv;
6168         Perl_croak(aTHX_ "Transliteration pattern not terminated");
6169     }
6170     if (s[-1] == PL_multi_open)
6171         s--;
6172
6173     s = scan_str(s,FALSE,FALSE);
6174     if (!s) {
6175         if (PL_lex_stuff)
6176             SvREFCNT_dec(PL_lex_stuff);
6177         PL_lex_stuff = Nullsv;
6178         if (PL_lex_repl)
6179             SvREFCNT_dec(PL_lex_repl);
6180         PL_lex_repl = Nullsv;
6181         Perl_croak(aTHX_ "Transliteration replacement not terminated");
6182     }
6183
6184     New(803,tbl,256,short);
6185     o = newPVOP(OP_TRANS, 0, (char*)tbl);
6186
6187     complement = del = squash = 0;
6188     while (strchr("cds", *s)) {
6189         if (*s == 'c')
6190             complement = OPpTRANS_COMPLEMENT;
6191         else if (*s == 'd')
6192             del = OPpTRANS_DELETE;
6193         else if (*s == 's')
6194             squash = OPpTRANS_SQUASH;
6195         s++;
6196     }
6197     o->op_private = del|squash|complement;
6198
6199     PL_lex_op = o;
6200     yylval.ival = OP_TRANS;
6201     return s;
6202 }
6203
6204 STATIC char *
6205 S_scan_heredoc(pTHX_ register char *s)
6206 {
6207     dTHR;
6208     SV *herewas;
6209     I32 op_type = OP_SCALAR;
6210     I32 len;
6211     SV *tmpstr;
6212     char term;
6213     register char *d;
6214     register char *e;
6215     char *peek;
6216     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6217
6218     s += 2;
6219     d = PL_tokenbuf;
6220     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6221     if (!outer)
6222         *d++ = '\n';
6223     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6224     if (*peek && strchr("`'\"",*peek)) {
6225         s = peek;
6226         term = *s++;
6227         s = delimcpy(d, e, s, PL_bufend, term, &len);
6228         d += len;
6229         if (s < PL_bufend)
6230             s++;
6231     }
6232     else {
6233         if (*s == '\\')
6234             s++, term = '\'';
6235         else
6236             term = '"';
6237         if (!isALNUM_lazy_if(s,UTF))
6238             deprecate("bare << to mean <<\"\"");
6239         for (; isALNUM_lazy_if(s,UTF); s++) {
6240             if (d < e)
6241                 *d++ = *s;
6242         }
6243     }
6244     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6245         Perl_croak(aTHX_ "Delimiter for here document is too long");
6246     *d++ = '\n';
6247     *d = '\0';
6248     len = d - PL_tokenbuf;
6249 #ifndef PERL_STRICT_CR
6250     d = strchr(s, '\r');
6251     if (d) {
6252         char *olds = s;
6253         s = d;
6254         while (s < PL_bufend) {
6255             if (*s == '\r') {
6256                 *d++ = '\n';
6257                 if (*++s == '\n')
6258                     s++;
6259             }
6260             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
6261                 *d++ = *s++;
6262                 s++;
6263             }
6264             else
6265                 *d++ = *s++;
6266         }
6267         *d = '\0';
6268         PL_bufend = d;
6269         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6270         s = olds;
6271     }
6272 #endif
6273     d = "\n";
6274     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6275         herewas = newSVpvn(s,PL_bufend-s);
6276     else
6277         s--, herewas = newSVpvn(s,d-s);
6278     s += SvCUR(herewas);
6279
6280     tmpstr = NEWSV(87,79);
6281     sv_upgrade(tmpstr, SVt_PVIV);
6282     if (term == '\'') {
6283         op_type = OP_CONST;
6284         SvIVX(tmpstr) = -1;
6285     }
6286     else if (term == '`') {
6287         op_type = OP_BACKTICK;
6288         SvIVX(tmpstr) = '\\';
6289     }
6290
6291     CLINE;
6292     PL_multi_start = CopLINE(PL_curcop);
6293     PL_multi_open = PL_multi_close = '<';
6294     term = *PL_tokenbuf;
6295     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6296         char *bufptr = PL_sublex_info.super_bufptr;
6297         char *bufend = PL_sublex_info.super_bufend;
6298         char *olds = s - SvCUR(herewas);
6299         s = strchr(bufptr, '\n');
6300         if (!s)
6301             s = bufend;
6302         d = s;
6303         while (s < bufend &&
6304           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6305             if (*s++ == '\n')
6306                 CopLINE_inc(PL_curcop);
6307         }
6308         if (s >= bufend) {
6309             CopLINE_set(PL_curcop, PL_multi_start);
6310             missingterm(PL_tokenbuf);
6311         }
6312         sv_setpvn(herewas,bufptr,d-bufptr+1);
6313         sv_setpvn(tmpstr,d+1,s-d);
6314         s += len - 1;
6315         sv_catpvn(herewas,s,bufend-s);
6316         (void)strcpy(bufptr,SvPVX(herewas));
6317
6318         s = olds;
6319         goto retval;
6320     }
6321     else if (!outer) {
6322         d = s;
6323         while (s < PL_bufend &&
6324           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6325             if (*s++ == '\n')
6326                 CopLINE_inc(PL_curcop);
6327         }
6328         if (s >= PL_bufend) {
6329             CopLINE_set(PL_curcop, PL_multi_start);
6330             missingterm(PL_tokenbuf);
6331         }
6332         sv_setpvn(tmpstr,d+1,s-d);
6333         s += len - 1;
6334         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6335
6336         sv_catpvn(herewas,s,PL_bufend-s);
6337         sv_setsv(PL_linestr,herewas);
6338         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6339         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6340     }
6341     else
6342         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
6343     while (s >= PL_bufend) {    /* multiple line string? */
6344         if (!outer ||
6345          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6346             CopLINE_set(PL_curcop, PL_multi_start);
6347             missingterm(PL_tokenbuf);
6348         }
6349         CopLINE_inc(PL_curcop);
6350         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6351 #ifndef PERL_STRICT_CR
6352         if (PL_bufend - PL_linestart >= 2) {
6353             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6354                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6355             {
6356                 PL_bufend[-2] = '\n';
6357                 PL_bufend--;
6358                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6359             }
6360             else if (PL_bufend[-1] == '\r')
6361                 PL_bufend[-1] = '\n';
6362         }
6363         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6364             PL_bufend[-1] = '\n';
6365 #endif
6366         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6367             SV *sv = NEWSV(88,0);
6368
6369             sv_upgrade(sv, SVt_PVMG);
6370             sv_setsv(sv,PL_linestr);
6371             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6372         }
6373         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6374             s = PL_bufend - 1;
6375             *s = ' ';
6376             sv_catsv(PL_linestr,herewas);
6377             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6378         }
6379         else {
6380             s = PL_bufend;
6381             sv_catsv(tmpstr,PL_linestr);
6382         }
6383     }
6384     s++;
6385 retval:
6386     PL_multi_end = CopLINE(PL_curcop);
6387     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6388         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6389         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6390     }
6391     SvREFCNT_dec(herewas);
6392     PL_lex_stuff = tmpstr;
6393     yylval.ival = op_type;
6394     return s;
6395 }
6396
6397 /* scan_inputsymbol
6398    takes: current position in input buffer
6399    returns: new position in input buffer
6400    side-effects: yylval and lex_op are set.
6401
6402    This code handles:
6403
6404    <>           read from ARGV
6405    <FH>         read from filehandle
6406    <pkg::FH>    read from package qualified filehandle
6407    <pkg'FH>     read from package qualified filehandle
6408    <$fh>        read from filehandle in $fh
6409    <*.h>        filename glob
6410
6411 */
6412
6413 STATIC char *
6414 S_scan_inputsymbol(pTHX_ char *start)
6415 {
6416     register char *s = start;           /* current position in buffer */
6417     register char *d;
6418     register char *e;
6419     char *end;
6420     I32 len;
6421
6422     d = PL_tokenbuf;                    /* start of temp holding space */
6423     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
6424     end = strchr(s, '\n');
6425     if (!end)
6426         end = PL_bufend;
6427     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
6428
6429     /* die if we didn't have space for the contents of the <>,
6430        or if it didn't end, or if we see a newline
6431     */
6432
6433     if (len >= sizeof PL_tokenbuf)
6434         Perl_croak(aTHX_ "Excessively long <> operator");
6435     if (s >= end)
6436         Perl_croak(aTHX_ "Unterminated <> operator");
6437
6438     s++;
6439
6440     /* check for <$fh>
6441        Remember, only scalar variables are interpreted as filehandles by
6442        this code.  Anything more complex (e.g., <$fh{$num}>) will be
6443        treated as a glob() call.
6444        This code makes use of the fact that except for the $ at the front,
6445        a scalar variable and a filehandle look the same.
6446     */
6447     if (*d == '$' && d[1]) d++;
6448
6449     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6450     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6451         d++;
6452
6453     /* If we've tried to read what we allow filehandles to look like, and
6454        there's still text left, then it must be a glob() and not a getline.
6455        Use scan_str to pull out the stuff between the <> and treat it
6456        as nothing more than a string.
6457     */
6458
6459     if (d - PL_tokenbuf != len) {
6460         yylval.ival = OP_GLOB;
6461         set_csh();
6462         s = scan_str(start,FALSE,FALSE);
6463         if (!s)
6464            Perl_croak(aTHX_ "Glob not terminated");
6465         return s;
6466     }
6467     else {
6468         /* we're in a filehandle read situation */
6469         d = PL_tokenbuf;
6470
6471         /* turn <> into <ARGV> */
6472         if (!len)
6473             (void)strcpy(d,"ARGV");
6474
6475         /* if <$fh>, create the ops to turn the variable into a
6476            filehandle
6477         */
6478         if (*d == '$') {
6479             I32 tmp;
6480
6481             /* try to find it in the pad for this block, otherwise find
6482                add symbol table ops
6483             */
6484             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6485                 OP *o = newOP(OP_PADSV, 0);
6486                 o->op_targ = tmp;
6487                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6488             }
6489             else {
6490                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6491                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6492                                             newUNOP(OP_RV2SV, 0,
6493                                                 newGVOP(OP_GV, 0, gv)));
6494             }
6495             PL_lex_op->op_flags |= OPf_SPECIAL;
6496             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6497             yylval.ival = OP_NULL;
6498         }
6499
6500         /* If it's none of the above, it must be a literal filehandle
6501            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6502         else {
6503             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6504             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6505             yylval.ival = OP_NULL;
6506         }
6507     }
6508
6509     return s;
6510 }
6511
6512
6513 /* scan_str
6514    takes: start position in buffer
6515           keep_quoted preserve \ on the embedded delimiter(s)
6516           keep_delims preserve the delimiters around the string
6517    returns: position to continue reading from buffer
6518    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6519         updates the read buffer.
6520
6521    This subroutine pulls a string out of the input.  It is called for:
6522         q               single quotes           q(literal text)
6523         '               single quotes           'literal text'
6524         qq              double quotes           qq(interpolate $here please)
6525         "               double quotes           "interpolate $here please"
6526         qx              backticks               qx(/bin/ls -l)
6527         `               backticks               `/bin/ls -l`
6528         qw              quote words             @EXPORT_OK = qw( func() $spam )
6529         m//             regexp match            m/this/
6530         s///            regexp substitute       s/this/that/
6531         tr///           string transliterate    tr/this/that/
6532         y///            string transliterate    y/this/that/
6533         ($*@)           sub prototypes          sub foo ($)
6534         (stuff)         sub attr parameters     sub foo : attr(stuff)
6535         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6536
6537    In most of these cases (all but <>, patterns and transliterate)
6538    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6539    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6540    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6541    calls scan_str().
6542
6543    It skips whitespace before the string starts, and treats the first
6544    character as the delimiter.  If the delimiter is one of ([{< then
6545    the corresponding "close" character )]}> is used as the closing
6546    delimiter.  It allows quoting of delimiters, and if the string has
6547    balanced delimiters ([{<>}]) it allows nesting.
6548
6549    The lexer always reads these strings into lex_stuff, except in the
6550    case of the operators which take *two* arguments (s/// and tr///)
6551    when it checks to see if lex_stuff is full (presumably with the 1st
6552    arg to s or tr) and if so puts the string into lex_repl.
6553
6554 */
6555
6556 STATIC char *
6557 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6558 {
6559     dTHR;
6560     SV *sv;                             /* scalar value: string */
6561     char *tmps;                         /* temp string, used for delimiter matching */
6562     register char *s = start;           /* current position in the buffer */
6563     register char term;                 /* terminating character */
6564     register char *to;                  /* current position in the sv's data */
6565     I32 brackets = 1;                   /* bracket nesting level */
6566     bool has_utf8 = FALSE;              /* is there any utf8 content? */
6567
6568     /* skip space before the delimiter */
6569     if (isSPACE(*s))
6570         s = skipspace(s);
6571
6572     /* mark where we are, in case we need to report errors */
6573     CLINE;
6574
6575     /* after skipping whitespace, the next character is the terminator */
6576     term = *s;
6577     if ((term & 0x80) && UTF)
6578         has_utf8 = TRUE;
6579
6580     /* mark where we are */
6581     PL_multi_start = CopLINE(PL_curcop);
6582     PL_multi_open = term;
6583
6584     /* find corresponding closing delimiter */
6585     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6586         term = tmps[5];
6587     PL_multi_close = term;
6588
6589     /* create a new SV to hold the contents.  87 is leak category, I'm
6590        assuming.  79 is the SV's initial length.  What a random number. */
6591     sv = NEWSV(87,79);
6592     sv_upgrade(sv, SVt_PVIV);
6593     SvIVX(sv) = term;
6594     (void)SvPOK_only(sv);               /* validate pointer */
6595
6596     /* move past delimiter and try to read a complete string */
6597     if (keep_delims)
6598         sv_catpvn(sv, s, 1);
6599     s++;
6600     for (;;) {
6601         /* extend sv if need be */
6602         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6603         /* set 'to' to the next character in the sv's string */
6604         to = SvPVX(sv)+SvCUR(sv);
6605
6606         /* if open delimiter is the close delimiter read unbridle */
6607         if (PL_multi_open == PL_multi_close) {
6608             for (; s < PL_bufend; s++,to++) {
6609                 /* embedded newlines increment the current line number */
6610                 if (*s == '\n' && !PL_rsfp)
6611                     CopLINE_inc(PL_curcop);
6612                 /* handle quoted delimiters */
6613                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6614                     if (!keep_quoted && s[1] == term)
6615                         s++;
6616                 /* any other quotes are simply copied straight through */
6617                     else
6618                         *to++ = *s++;
6619                 }
6620                 /* terminate when run out of buffer (the for() condition), or
6621                    have found the terminator */
6622                 else if (*s == term)
6623                     break;
6624                 else if (!has_utf8 && (*s & 0x80) && UTF)
6625                     has_utf8 = TRUE;
6626                 *to = *s;
6627             }
6628         }
6629
6630         /* if the terminator isn't the same as the start character (e.g.,
6631            matched brackets), we have to allow more in the quoting, and
6632            be prepared for nested brackets.
6633         */
6634         else {
6635             /* read until we run out of string, or we find the terminator */
6636             for (; s < PL_bufend; s++,to++) {
6637                 /* embedded newlines increment the line count */
6638                 if (*s == '\n' && !PL_rsfp)
6639                     CopLINE_inc(PL_curcop);
6640                 /* backslashes can escape the open or closing characters */
6641                 if (*s == '\\' && s+1 < PL_bufend) {
6642                     if (!keep_quoted &&
6643                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6644                         s++;
6645                     else
6646                         *to++ = *s++;
6647                 }
6648                 /* allow nested opens and closes */
6649                 else if (*s == PL_multi_close && --brackets <= 0)
6650                     break;
6651                 else if (*s == PL_multi_open)
6652                     brackets++;
6653                 else if (!has_utf8 && (*s & 0x80) && UTF)
6654                     has_utf8 = TRUE;
6655                 *to = *s;
6656             }
6657         }
6658         /* terminate the copied string and update the sv's end-of-string */
6659         *to = '\0';
6660         SvCUR_set(sv, to - SvPVX(sv));
6661
6662         /*
6663          * this next chunk reads more into the buffer if we're not done yet
6664          */
6665
6666         if (s < PL_bufend)
6667             break;              /* handle case where we are done yet :-) */
6668
6669 #ifndef PERL_STRICT_CR
6670         if (to - SvPVX(sv) >= 2) {
6671             if ((to[-2] == '\r' && to[-1] == '\n') ||
6672                 (to[-2] == '\n' && to[-1] == '\r'))
6673             {
6674                 to[-2] = '\n';
6675                 to--;
6676                 SvCUR_set(sv, to - SvPVX(sv));
6677             }
6678             else if (to[-1] == '\r')
6679                 to[-1] = '\n';
6680         }
6681         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6682             to[-1] = '\n';
6683 #endif
6684
6685         /* if we're out of file, or a read fails, bail and reset the current
6686            line marker so we can report where the unterminated string began
6687         */
6688         if (!PL_rsfp ||
6689          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6690             sv_free(sv);
6691             CopLINE_set(PL_curcop, PL_multi_start);
6692             return Nullch;
6693         }
6694         /* we read a line, so increment our line counter */
6695         CopLINE_inc(PL_curcop);
6696
6697         /* update debugger info */
6698         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6699             SV *sv = NEWSV(88,0);
6700
6701             sv_upgrade(sv, SVt_PVMG);
6702             sv_setsv(sv,PL_linestr);
6703             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6704         }
6705
6706         /* having changed the buffer, we must update PL_bufend */
6707         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6708     }
6709
6710     /* at this point, we have successfully read the delimited string */
6711
6712     if (keep_delims)
6713         sv_catpvn(sv, s, 1);
6714     if (has_utf8)
6715         SvUTF8_on(sv);
6716     PL_multi_end = CopLINE(PL_curcop);
6717     s++;
6718
6719     /* if we allocated too much space, give some back */
6720     if (SvCUR(sv) + 5 < SvLEN(sv)) {
6721         SvLEN_set(sv, SvCUR(sv) + 1);
6722         Renew(SvPVX(sv), SvLEN(sv), char);
6723     }
6724
6725     /* decide whether this is the first or second quoted string we've read
6726        for this op
6727     */
6728
6729     if (PL_lex_stuff)
6730         PL_lex_repl = sv;
6731     else
6732         PL_lex_stuff = sv;
6733     return s;
6734 }
6735
6736 /*
6737   scan_num
6738   takes: pointer to position in buffer
6739   returns: pointer to new position in buffer
6740   side-effects: builds ops for the constant in yylval.op
6741
6742   Read a number in any of the formats that Perl accepts:
6743
6744   0(x[0-7A-F]+)|([0-7]+)|(b[01])
6745   [\d_]+(\.[\d_]*)?[Ee](\d+)
6746
6747   Underbars (_) are allowed in decimal numbers.  If -w is on,
6748   underbars before a decimal point must be at three digit intervals.
6749
6750   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6751   thing it reads.
6752
6753   If it reads a number without a decimal point or an exponent, it will
6754   try converting the number to an integer and see if it can do so
6755   without loss of precision.
6756 */
6757
6758 char *
6759 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
6760 {
6761     register char *s = start;           /* current position in buffer */
6762     register char *d;                   /* destination in temp buffer */
6763     register char *e;                   /* end of temp buffer */
6764     NV nv;                              /* number read, as a double */
6765     SV *sv = Nullsv;                    /* place to put the converted number */
6766     bool floatit;                       /* boolean: int or float? */
6767     char *lastub = 0;                   /* position of last underbar */
6768     static char number_too_long[] = "Number too long";
6769
6770     /* We use the first character to decide what type of number this is */
6771
6772     switch (*s) {
6773     default:
6774       Perl_croak(aTHX_ "panic: scan_num");
6775
6776     /* if it starts with a 0, it could be an octal number, a decimal in
6777        0.13 disguise, or a hexadecimal number, or a binary number. */
6778     case '0':
6779         {
6780           /* variables:
6781              u          holds the "number so far"
6782              shift      the power of 2 of the base
6783                         (hex == 4, octal == 3, binary == 1)
6784              overflowed was the number more than we can hold?
6785
6786              Shift is used when we add a digit.  It also serves as an "are
6787              we in octal/hex/binary?" indicator to disallow hex characters
6788              when in octal mode.
6789            */
6790             dTHR;
6791             NV n = 0.0;
6792             UV u = 0;
6793             I32 shift;
6794             bool overflowed = FALSE;
6795             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6796             static char* bases[5] = { "", "binary", "", "octal",
6797                                       "hexadecimal" };
6798             static char* Bases[5] = { "", "Binary", "", "Octal",
6799                                       "Hexadecimal" };
6800             static char *maxima[5] = { "",
6801                                        "0b11111111111111111111111111111111",
6802                                        "",
6803                                        "037777777777",
6804                                        "0xffffffff" };
6805             char *base, *Base, *max;
6806
6807             /* check for hex */
6808             if (s[1] == 'x') {
6809                 shift = 4;
6810                 s += 2;
6811             } else if (s[1] == 'b') {
6812                 shift = 1;
6813                 s += 2;
6814             }
6815             /* check for a decimal in disguise */
6816             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6817                 goto decimal;
6818             /* so it must be octal */
6819             else
6820                 shift = 3;
6821
6822             base = bases[shift];
6823             Base = Bases[shift];
6824             max  = maxima[shift];
6825
6826             /* read the rest of the number */
6827             for (;;) {
6828                 /* x is used in the overflow test,
6829                    b is the digit we're adding on. */
6830                 UV x, b;
6831
6832                 switch (*s) {
6833
6834                 /* if we don't mention it, we're done */
6835                 default:
6836                     goto out;
6837
6838                 /* _ are ignored */
6839                 case '_':
6840                     s++;
6841                     break;
6842
6843                 /* 8 and 9 are not octal */
6844                 case '8': case '9':
6845                     if (shift == 3)
6846                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6847                     /* FALL THROUGH */
6848
6849                 /* octal digits */
6850                 case '2': case '3': case '4':
6851                 case '5': case '6': case '7':
6852                     if (shift == 1)
6853                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6854                     /* FALL THROUGH */
6855
6856                 case '0': case '1':
6857                     b = *s++ & 15;              /* ASCII digit -> value of digit */
6858                     goto digit;
6859
6860                 /* hex digits */
6861                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6862                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6863                     /* make sure they said 0x */
6864                     if (shift != 4)
6865                         goto out;
6866                     b = (*s++ & 7) + 9;
6867
6868                     /* Prepare to put the digit we have onto the end
6869                        of the number so far.  We check for overflows.
6870                     */
6871
6872                   digit:
6873                     if (!overflowed) {
6874                         x = u << shift; /* make room for the digit */
6875
6876                         if ((x >> shift) != u
6877                             && !(PL_hints & HINT_NEW_BINARY)) {
6878                             dTHR;
6879                             overflowed = TRUE;
6880                             n = (NV) u;
6881                             if (ckWARN_d(WARN_OVERFLOW))
6882                                 Perl_warner(aTHX_ WARN_OVERFLOW,
6883                                             "Integer overflow in %s number",
6884                                             base);
6885                         } else
6886                             u = x | b;          /* add the digit to the end */
6887                     }
6888                     if (overflowed) {
6889                         n *= nvshift[shift];
6890                         /* If an NV has not enough bits in its
6891                          * mantissa to represent an UV this summing of
6892                          * small low-order numbers is a waste of time
6893                          * (because the NV cannot preserve the
6894                          * low-order bits anyway): we could just
6895                          * remember when did we overflow and in the
6896                          * end just multiply n by the right
6897                          * amount. */
6898                         n += (NV) b;
6899                     }
6900                     break;
6901                 }
6902             }
6903
6904           /* if we get here, we had success: make a scalar value from
6905              the number.
6906           */
6907           out:
6908             sv = NEWSV(92,0);
6909             if (overflowed) {
6910                 dTHR;
6911                 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6912                     Perl_warner(aTHX_ WARN_PORTABLE,
6913                                 "%s number > %s non-portable",
6914                                 Base, max);
6915                 sv_setnv(sv, n);
6916             }
6917             else {
6918 #if UVSIZE > 4
6919                 dTHR;
6920                 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6921                     Perl_warner(aTHX_ WARN_PORTABLE,
6922                                 "%s number > %s non-portable",
6923                                 Base, max);
6924 #endif
6925                 sv_setuv(sv, u);
6926             }
6927             if (PL_hints & HINT_NEW_BINARY)
6928                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6929         }
6930         break;
6931
6932     /*
6933       handle decimal numbers.
6934       we're also sent here when we read a 0 as the first digit
6935     */
6936     case '1': case '2': case '3': case '4': case '5':
6937     case '6': case '7': case '8': case '9': case '.':
6938       decimal:
6939         d = PL_tokenbuf;
6940         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6941         floatit = FALSE;
6942
6943         /* read next group of digits and _ and copy into d */
6944         while (isDIGIT(*s) || *s == '_') {
6945             /* skip underscores, checking for misplaced ones
6946                if -w is on
6947             */
6948             if (*s == '_') {
6949                 dTHR;                   /* only for ckWARN */
6950                 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6951                     Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6952                 lastub = ++s;
6953             }
6954             else {
6955                 /* check for end of fixed-length buffer */
6956                 if (d >= e)
6957                     Perl_croak(aTHX_ number_too_long);
6958                 /* if we're ok, copy the character */
6959                 *d++ = *s++;
6960             }
6961         }
6962
6963         /* final misplaced underbar check */
6964         if (lastub && s - lastub != 3) {
6965             dTHR;
6966             if (ckWARN(WARN_SYNTAX))
6967                 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6968         }
6969
6970         /* read a decimal portion if there is one.  avoid
6971            3..5 being interpreted as the number 3. followed
6972            by .5
6973         */
6974         if (*s == '.' && s[1] != '.') {
6975             floatit = TRUE;
6976             *d++ = *s++;
6977
6978             /* copy, ignoring underbars, until we run out of
6979                digits.  Note: no misplaced underbar checks!
6980             */
6981             for (; isDIGIT(*s) || *s == '_'; s++) {
6982                 /* fixed length buffer check */
6983                 if (d >= e)
6984                     Perl_croak(aTHX_ number_too_long);
6985                 if (*s != '_')
6986                     *d++ = *s;
6987             }
6988             if (*s == '.' && isDIGIT(s[1])) {
6989                 /* oops, it's really a v-string, but without the "v" */
6990                 s = start - 1;
6991                 goto vstring;
6992             }
6993         }
6994
6995         /* read exponent part, if present */
6996         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6997             floatit = TRUE;
6998             s++;
6999
7000             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7001             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
7002
7003             /* allow positive or negative exponent */
7004             if (*s == '+' || *s == '-')
7005                 *d++ = *s++;
7006
7007             /* read digits of exponent (no underbars :-) */
7008             while (isDIGIT(*s)) {
7009                 if (d >= e)
7010                     Perl_croak(aTHX_ number_too_long);
7011                 *d++ = *s++;
7012             }
7013         }
7014
7015         /* terminate the string */
7016         *d = '\0';
7017
7018         /* make an sv from the string */
7019         sv = NEWSV(92,0);
7020
7021 #if defined(Strtol) && defined(Strtoul)
7022
7023         /*
7024            strtol/strtoll sets errno to ERANGE if the number is too big
7025            for an integer. We try to do an integer conversion first
7026            if no characters indicating "float" have been found.
7027          */
7028
7029         if (!floatit) {
7030             IV iv;
7031             UV uv;
7032             errno = 0;
7033             if (*PL_tokenbuf == '-')
7034                 iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
7035             else
7036                 uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
7037             if (errno)
7038                 floatit = TRUE; /* Probably just too large. */
7039             else if (*PL_tokenbuf == '-')
7040                 sv_setiv(sv, iv);
7041             else if (uv <= IV_MAX)
7042                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7043             else
7044                 sv_setuv(sv, uv);
7045         }
7046         if (floatit) {
7047             nv = Atof(PL_tokenbuf);
7048             sv_setnv(sv, nv);
7049         }
7050 #else
7051         /*
7052            No working strtou?ll?.
7053
7054            Unfortunately atol() doesn't do range checks (returning
7055            LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
7056            everywhere [1], so we cannot use use atol() (or atoll()).
7057            If we could, they would be used, as Atol(), very much like
7058            Strtol() and Strtoul() are used above.
7059
7060            [1] XXX Configure test needed to check for atol()
7061                    (and atoll()) overflow behaviour XXX
7062
7063            --jhi
7064
7065            We need to do this the hard way.  */
7066
7067         nv = Atof(PL_tokenbuf);
7068
7069         /* See if we can make do with an integer value without loss of
7070            precision.  We use U_V to cast to a UV, because some
7071            compilers have issues.  Then we try casting it back and see
7072            if it was the same [1].  We only do this if we know we
7073            specifically read an integer.  If floatit is true, then we
7074            don't need to do the conversion at all.
7075
7076            [1] Note that this is lossy if our NVs cannot preserve our
7077            UVs.  There are metaconfig defines NV_PRESERVES_UV (a boolean)
7078            and NV_PRESERVES_UV_BITS (a number), but in general we really
7079            do hope all such potentially lossy platforms have strtou?ll?
7080            to do a lossless IV/UV conversion.
7081
7082            Maybe could do some tricks with DBL_DIG, LDBL_DIG and
7083            DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
7084            as NV_DIG and NV_MANT_DIG)?
7085
7086            --jhi
7087            */
7088         {
7089             UV uv = U_V(nv);
7090             if (!floatit && (NV)uv == nv) {
7091                 if (uv <= IV_MAX)
7092                     sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7093                 else
7094                     sv_setuv(sv, uv);
7095             }
7096             else
7097                 sv_setnv(sv, nv);
7098         }
7099 #endif
7100         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7101                        (PL_hints & HINT_NEW_INTEGER) )
7102             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7103                               (floatit ? "float" : "integer"),
7104                               sv, Nullsv, NULL);
7105         break;
7106
7107     /* if it starts with a v, it could be a v-string */
7108     case 'v':
7109 vstring:
7110         {
7111             char *pos = s;
7112             pos++;
7113             while (isDIGIT(*pos) || *pos == '_')
7114                 pos++;
7115             if (!isALPHA(*pos)) {
7116                 UV rev;
7117                 U8 tmpbuf[UTF8_MAXLEN];
7118                 U8 *tmpend;
7119                 bool utf8 = FALSE;
7120                 s++;                            /* get past 'v' */
7121
7122                 sv = NEWSV(92,5);
7123                 sv_setpvn(sv, "", 0);
7124
7125                 for (;;) {
7126                     if (*s == '0' && isDIGIT(s[1]))
7127                         yyerror("Octal number in vector unsupported");
7128                     rev = 0;
7129                     {
7130                         /* this is atoi() that tolerates underscores */
7131                         char *end = pos;
7132                         UV mult = 1;
7133                         while (--end >= s) {
7134                             UV orev;
7135                             if (*end == '_')
7136                                 continue;
7137                             orev = rev;
7138                             rev += (*end - '0') * mult;
7139                             mult *= 10;
7140                             if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7141                                 Perl_warner(aTHX_ WARN_OVERFLOW,
7142                                             "Integer overflow in decimal number");
7143                         }
7144                     }
7145                     tmpend = uv_to_utf8(tmpbuf, rev);
7146                     utf8 = utf8 || rev > 127;
7147                     sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7148                     if (*pos == '.' && isDIGIT(pos[1]))
7149                         s = ++pos;
7150                     else {
7151                         s = pos;
7152                         break;
7153                     }
7154                     while (isDIGIT(*pos) || *pos == '_')
7155                         pos++;
7156                 }
7157
7158                 SvPOK_on(sv);
7159                 SvREADONLY_on(sv);
7160                 if (utf8) {
7161                     SvUTF8_on(sv);
7162                     sv_utf8_downgrade(sv, TRUE);
7163                 }
7164             }
7165         }
7166         break;
7167     }
7168
7169     /* make the op for the constant and return */
7170
7171     if (sv)
7172         lvalp->opval = newSVOP(OP_CONST, 0, sv);
7173     else
7174         lvalp->opval = Nullop;
7175
7176     return s;
7177 }
7178
7179 STATIC char *
7180 S_scan_formline(pTHX_ register char *s)
7181 {
7182     dTHR;
7183     register char *eol;
7184     register char *t;
7185     SV *stuff = newSVpvn("",0);
7186     bool needargs = FALSE;
7187
7188     while (!needargs) {
7189         if (*s == '.' || *s == /*{*/'}') {
7190             /*SUPPRESS 530*/
7191 #ifdef PERL_STRICT_CR
7192             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7193 #else
7194             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7195 #endif
7196             if (*t == '\n' || t == PL_bufend)
7197                 break;
7198         }
7199         if (PL_in_eval && !PL_rsfp) {
7200             eol = strchr(s,'\n');
7201             if (!eol++)
7202                 eol = PL_bufend;
7203         }
7204         else
7205             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7206         if (*s != '#') {
7207             for (t = s; t < eol; t++) {
7208                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7209                     needargs = FALSE;
7210                     goto enough;        /* ~~ must be first line in formline */
7211                 }
7212                 if (*t == '@' || *t == '^')
7213                     needargs = TRUE;
7214             }
7215             sv_catpvn(stuff, s, eol-s);
7216 #ifndef PERL_STRICT_CR
7217             if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7218                 char *end = SvPVX(stuff) + SvCUR(stuff);
7219                 end[-2] = '\n';
7220                 end[-1] = '\0';
7221                 SvCUR(stuff)--;
7222             }
7223 #endif
7224         }
7225         s = eol;
7226         if (PL_rsfp) {
7227             s = filter_gets(PL_linestr, PL_rsfp, 0);
7228             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7229             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7230             if (!s) {
7231                 s = PL_bufptr;
7232                 yyerror("Format not terminated");
7233                 break;
7234             }
7235         }
7236         incline(s);
7237     }
7238   enough:
7239     if (SvCUR(stuff)) {
7240         PL_expect = XTERM;
7241         if (needargs) {
7242             PL_lex_state = LEX_NORMAL;
7243             PL_nextval[PL_nexttoke].ival = 0;
7244             force_next(',');
7245         }
7246         else
7247             PL_lex_state = LEX_FORMLINE;
7248         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7249         force_next(THING);
7250         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7251         force_next(LSTOP);
7252     }
7253     else {
7254         SvREFCNT_dec(stuff);
7255         PL_lex_formbrack = 0;
7256         PL_bufptr = s;
7257     }
7258     return s;
7259 }
7260
7261 STATIC void
7262 S_set_csh(pTHX)
7263 {
7264 #ifdef CSH
7265     if (!PL_cshlen)
7266         PL_cshlen = strlen(PL_cshname);
7267 #endif
7268 }
7269
7270 I32
7271 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7272 {
7273     dTHR;
7274     I32 oldsavestack_ix = PL_savestack_ix;
7275     CV* outsidecv = PL_compcv;
7276     AV* comppadlist;
7277
7278     if (PL_compcv) {
7279         assert(SvTYPE(PL_compcv) == SVt_PVCV);
7280     }
7281     SAVEI32(PL_subline);
7282     save_item(PL_subname);
7283     SAVEI32(PL_padix);
7284     SAVECOMPPAD();
7285     SAVESPTR(PL_comppad_name);
7286     SAVESPTR(PL_compcv);
7287     SAVEI32(PL_comppad_name_fill);
7288     SAVEI32(PL_min_intro_pending);
7289     SAVEI32(PL_max_intro_pending);
7290     SAVEI32(PL_pad_reset_pending);
7291
7292     PL_compcv = (CV*)NEWSV(1104,0);
7293     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7294     CvFLAGS(PL_compcv) |= flags;
7295
7296     PL_comppad = newAV();
7297     av_push(PL_comppad, Nullsv);
7298     PL_curpad = AvARRAY(PL_comppad);
7299     PL_comppad_name = newAV();
7300     PL_comppad_name_fill = 0;
7301     PL_min_intro_pending = 0;
7302     PL_padix = 0;
7303     PL_subline = CopLINE(PL_curcop);
7304 #ifdef USE_THREADS
7305     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7306     PL_curpad[0] = (SV*)newAV();
7307     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
7308 #endif /* USE_THREADS */
7309
7310     comppadlist = newAV();
7311     AvREAL_off(comppadlist);
7312     av_store(comppadlist, 0, (SV*)PL_comppad_name);
7313     av_store(comppadlist, 1, (SV*)PL_comppad);
7314
7315     CvPADLIST(PL_compcv) = comppadlist;
7316     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7317 #ifdef USE_THREADS
7318     CvOWNER(PL_compcv) = 0;
7319     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7320     MUTEX_INIT(CvMUTEXP(PL_compcv));
7321 #endif /* USE_THREADS */
7322
7323     return oldsavestack_ix;
7324 }
7325
7326 int
7327 Perl_yywarn(pTHX_ char *s)
7328 {
7329     dTHR;
7330     PL_in_eval |= EVAL_WARNONLY;
7331     yyerror(s);
7332     PL_in_eval &= ~EVAL_WARNONLY;
7333     return 0;
7334 }
7335
7336 int
7337 Perl_yyerror(pTHX_ char *s)
7338 {
7339     dTHR;
7340     char *where = NULL;
7341     char *context = NULL;
7342     int contlen = -1;
7343     SV *msg;
7344
7345     if (!yychar || (yychar == ';' && !PL_rsfp))
7346         where = "at EOF";
7347     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7348       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7349         while (isSPACE(*PL_oldoldbufptr))
7350             PL_oldoldbufptr++;
7351         context = PL_oldoldbufptr;
7352         contlen = PL_bufptr - PL_oldoldbufptr;
7353     }
7354     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7355       PL_oldbufptr != PL_bufptr) {
7356         while (isSPACE(*PL_oldbufptr))
7357             PL_oldbufptr++;
7358         context = PL_oldbufptr;
7359         contlen = PL_bufptr - PL_oldbufptr;
7360     }
7361     else if (yychar > 255)
7362         where = "next token ???";
7363 #ifdef USE_PURE_BISON
7364 /*  GNU Bison sets the value -2 */
7365     else if (yychar == -2) {
7366 #else
7367     else if ((yychar & 127) == 127) {
7368 #endif
7369         if (PL_lex_state == LEX_NORMAL ||
7370            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7371             where = "at end of line";
7372         else if (PL_lex_inpat)
7373             where = "within pattern";
7374         else
7375             where = "within string";
7376     }
7377     else {
7378         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7379         if (yychar < 32)
7380             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7381         else if (isPRINT_LC(yychar))
7382             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7383         else
7384             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7385         where = SvPVX(where_sv);
7386     }
7387     msg = sv_2mortal(newSVpv(s, 0));
7388     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7389                    CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7390     if (context)
7391         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7392     else
7393         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7394     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7395         Perl_sv_catpvf(aTHX_ msg,
7396         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7397                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7398         PL_multi_end = 0;
7399     }
7400     if (PL_in_eval & EVAL_WARNONLY)
7401         Perl_warn(aTHX_ "%"SVf, msg);
7402     else
7403         qerror(msg);
7404     if (PL_error_count >= 10) {
7405         if (PL_in_eval && SvCUR(ERRSV))
7406             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7407                        ERRSV, CopFILE(PL_curcop));
7408         else
7409             Perl_croak(aTHX_ "%s has too many errors.\n",
7410                        CopFILE(PL_curcop));
7411     }
7412     PL_in_my = 0;
7413     PL_in_my_stash = Nullhv;
7414     return 0;
7415 }
7416
7417 STATIC char*
7418 S_swallow_bom(pTHX_ U8 *s)
7419 {
7420     STRLEN slen;
7421     slen = SvCUR(PL_linestr);
7422     switch (*s) {
7423     case 0xFF:
7424         if (s[1] == 0xFE) {
7425             /* UTF-16 little-endian */
7426             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
7427                 Perl_croak(aTHX_ "Unsupported script encoding");
7428 #ifndef PERL_NO_UTF16_FILTER
7429             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7430             s += 2;
7431             if (PL_bufend > (char*)s) {
7432                 U8 *news;
7433                 I32 newlen;
7434
7435                 filter_add(utf16rev_textfilter, NULL);
7436                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7437                 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7438                                                  PL_bufend - (char*)s - 1,
7439                                                  &newlen);
7440                 Copy(news, s, newlen, U8);
7441                 SvCUR_set(PL_linestr, newlen);
7442                 PL_bufend = SvPVX(PL_linestr) + newlen;
7443                 news[newlen++] = '\0';
7444                 Safefree(news);
7445             }
7446 #else
7447             Perl_croak(aTHX_ "Unsupported script encoding");
7448 #endif
7449         }
7450         break;
7451     case 0xFE:
7452         if (s[1] == 0xFF) {   /* UTF-16 big-endian */
7453 #ifndef PERL_NO_UTF16_FILTER
7454             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7455             s += 2;
7456             if (PL_bufend > (char *)s) {
7457                 U8 *news;
7458                 I32 newlen;
7459
7460                 filter_add(utf16_textfilter, NULL);
7461                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7462                 PL_bufend = (char*)utf16_to_utf8(s, news,
7463                                                  PL_bufend - (char*)s,
7464                                                  &newlen);
7465                 Copy(news, s, newlen, U8);
7466                 SvCUR_set(PL_linestr, newlen);
7467                 PL_bufend = SvPVX(PL_linestr) + newlen;
7468                 news[newlen++] = '\0';
7469                 Safefree(news);
7470             }
7471 #else
7472             Perl_croak(aTHX_ "Unsupported script encoding");
7473 #endif
7474         }
7475         break;
7476     case 0xEF:
7477         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7478             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7479             s += 3;                      /* UTF-8 */
7480         }
7481         break;
7482     case 0:
7483         if (slen > 3 && s[1] == 0 &&  /* UTF-32 big-endian */
7484             s[2] == 0xFE && s[3] == 0xFF)
7485         {
7486             Perl_croak(aTHX_ "Unsupported script encoding");
7487         }
7488     }
7489     return (char*)s;
7490 }
7491
7492 #ifdef PERL_OBJECT
7493 #include "XSUB.h"
7494 #endif
7495
7496 /*
7497  * restore_rsfp
7498  * Restore a source filter.
7499  */
7500
7501 static void
7502 restore_rsfp(pTHXo_ void *f)
7503 {
7504     PerlIO *fp = (PerlIO*)f;
7505
7506     if (PL_rsfp == PerlIO_stdin())
7507         PerlIO_clearerr(PL_rsfp);
7508     else if (PL_rsfp && (PL_rsfp != fp))
7509         PerlIO_close(PL_rsfp);
7510     PL_rsfp = fp;
7511 }
7512
7513 #ifndef PERL_NO_UTF16_FILTER
7514 static I32
7515 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
7516 {
7517     I32 count = FILTER_READ(idx+1, sv, maxlen);
7518     if (count) {
7519         U8* tmps;
7520         U8* tend;
7521         I32 newlen;
7522         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7523         if (!*SvPV_nolen(sv))
7524         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7525         return count;
7526
7527         tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7528         sv_usepvn(sv, (char*)tmps, tend - tmps);
7529     }
7530     return count;
7531 }
7532
7533 static I32
7534 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
7535 {
7536     I32 count = FILTER_READ(idx+1, sv, maxlen);
7537     if (count) {
7538         U8* tmps;
7539         U8* tend;
7540         I32 newlen;
7541         if (!*SvPV_nolen(sv))
7542         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7543         return count;
7544
7545         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7546         tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7547         sv_usepvn(sv, (char*)tmps, tend - tmps);
7548     }
7549     return count;
7550 }
7551 #endif