toke.c

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