toke.c

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