toke.c

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