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