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