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