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