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