toke.c

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