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