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