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