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