toke.c

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