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