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