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