toke.c

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