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