toke.c

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