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