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