toke.c

   1 /*    toke.c
   2  *
   3  *    Copyright (c) 1991-2000, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  *   "It all comes from here, the stench and the peril."  --Frodo
  12  */
  13
  14 /*
  15  * This file is the lexer for Perl.  It's closely linked to the
  16  * parser, perly.y.
  17  *
  18  * The main routine is yylex(), which returns the next token.
  19  */
  20
  21 #include "EXTERN.h"
  22 #define PERL_IN_TOKE_C
  23 #include "perl.h"
  24
  25 #define yychar  PL_yychar
  26 #define yylval  PL_yylval
  27
  28 static char ident_too_long[] = "Identifier too long";
  29
  30 static void restore_rsfp(pTHXo_ void *f);
  31 #ifndef PERL_NO_UTF16_FILTER
  32 static I32 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
  33 static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
  34 #endif
  35
  36 #define XFAKEBRACK 128
  37 #define XENUMMASK 127
  38
  39 /*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/
  40 #define UTF (PL_hints & HINT_UTF8)
  41
  42 /* In variables name $^X, these are the legal values for X.
  43  * 1999-02-27 mjd-perl-patch@plover.com */
  44 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
  45
  46 /* On MacOS, respect nonbreaking spaces */
  47 #ifdef MACOS_TRADITIONAL
  48 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
  49 #else
  50 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
  51 #endif
  52
  53 /* LEX_* are values for PL_lex_state, the state of the lexer.
  54  * They are arranged oddly so that the guard on the switch statement
  55  * can get by with a single comparison (if the compiler is smart enough).
  56  */
  57
  58 /* #define LEX_NOTPARSING               11 is done in perl.h. */
  59
  60 #define LEX_NORMAL              10
  61 #define LEX_INTERPNORMAL         9
  62 #define LEX_INTERPCASEMOD        8
  63 #define LEX_INTERPPUSH           7
  64 #define LEX_INTERPSTART          6
  65 #define LEX_INTERPEND            5
  66 #define LEX_INTERPENDMAYBE       4
  67 #define LEX_INTERPCONCAT         3
  68 #define LEX_INTERPCONST          2
  69 #define LEX_FORMLINE             1
  70 #define LEX_KNOWNEXT             0
  71
  72 #ifdef ff_next
  73 #undef ff_next
  74 #endif
  75
  76 #ifdef USE_PURE_BISON
  77 #  ifndef YYMAXLEVEL
  78 #    define YYMAXLEVEL 100
  79 #  endif
  80 YYSTYPE* yylval_pointer[YYMAXLEVEL];
  81 int* yychar_pointer[YYMAXLEVEL];
  82 int yyactlevel = 0;
  83 #  undef yylval
  84 #  undef yychar
  85 #  define yylval (*yylval_pointer[yyactlevel])
  86 #  define yychar (*yychar_pointer[yyactlevel])
  87 #  define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
  88 #  undef yylex
  89 #  define yylex()      Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
  90 #endif
  91
  92 #include "keywords.h"
  93
  94 /* CLINE is a macro that ensures PL_copline has a sane value */
  95
  96 #ifdef CLINE
  97 #undef CLINE
  98 #endif
  99 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
 100
 101 /*
 102  * Convenience functions to return different tokens and prime the
 103  * lexer for the next token.  They all take an argument.
 104  *
 105  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
 106  * OPERATOR     : generic operator
 107  * AOPERATOR    : assignment operator
 108  * PREBLOCK     : beginning the block after an if, while, foreach, ...
 109  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
 110  * PREREF       : *EXPR where EXPR is not a simple identifier
 111  * TERM         : expression term
 112  * LOOPX        : loop exiting command (goto, last, dump, etc)
 113  * FTST         : file test operator
 114  * FUN0         : zero-argument function
 115  * FUN1         : not used, except for not, which isn't a UNIOP
 116  * BOop         : bitwise or or xor
 117  * BAop         : bitwise and
 118  * SHop         : shift operator
 119  * PWop         : power operator
 120  * PMop         : pattern-matching operator
 121  * Aop          : addition-level operator
 122  * Mop          : multiplication-level operator
 123  * Eop          : equality-testing operator
 124  * Rop        : relational operator <= != gt
 125  *
 126  * Also see LOP and lop() below.
 127  */
 128
 129 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
 130 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
 131 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
 132 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
 133 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
 134 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
 135 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
 136 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
 137 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
 138 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
 139 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
 140 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
 141 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
 142 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
 143 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
 144 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
 145 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
 146 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
 147 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
 148 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
 149
 150 /* This bit of chicanery makes a unary function followed by
 151  * a parenthesis into a function with one argument, highest precedence.
 152  */
 153 #define UNI(f) return(yylval.ival = f, \
 154         PL_expect = XTERM, \
 155         PL_bufptr = s, \
 156         PL_last_uni = PL_oldbufptr, \
 157         PL_last_lop_op = f, \
 158         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 159
 160 #define UNIBRACK(f) return(yylval.ival = f, \
 161         PL_bufptr = s, \
 162         PL_last_uni = PL_oldbufptr, \
 163         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 164
 165 /* grandfather return to old style */
 166 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 167
 168 /*
 169  * S_ao
 170  *
 171  * This subroutine detects &&= and ||= and turns an ANDAND or OROR
 172  * into an OP_ANDASSIGN or OP_ORASSIGN
 173  */
 174
 175 STATIC int
 176 S_ao(pTHX_ int toketype)
 177 {
 178     if (*PL_bufptr == '=') {
 179         PL_bufptr++;
 180         if (toketype == ANDAND)
 181             yylval.ival = OP_ANDASSIGN;
 182         else if (toketype == OROR)
 183             yylval.ival = OP_ORASSIGN;
 184         toketype = ASSIGNOP;
 185     }
 186     return toketype;
 187 }
 188
 189 /*
 190  * S_no_op
 191  * When Perl expects an operator and finds something else, no_op
 192  * prints the warning.  It always prints "<something> found where
 193  * operator expected.  It prints "Missing semicolon on previous line?"
 194  * if the surprise occurs at the start of the line.  "do you need to
 195  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 196  * where the compiler doesn't know if foo is a method call or a function.
 197  * It prints "Missing operator before end of line" if there's nothing
 198  * after the missing operator, or "... before <...>" if there is something
 199  * after the missing operator.
 200  */
 201
 202 STATIC void
 203 S_no_op(pTHX_ char *what, char *s)
 204 {
 205     char *oldbp = PL_bufptr;
 206     bool is_first = (PL_oldbufptr == PL_linestart);
 207
 208     if (!s)
 209         s = oldbp;
 210     else
 211         PL_bufptr = s;
 212     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 213     if (is_first)
 214         Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
 215     else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
 216         char *t;
 217         for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
 218         if (t < PL_bufptr && isSPACE(*t))
 219             Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
 220                 t - PL_oldoldbufptr, PL_oldoldbufptr);
 221     }
 222     else {
 223         assert(s >= oldbp);
 224         Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
 225     }
 226     PL_bufptr = oldbp;
 227 }
 228
 229 /*
 230  * S_missingterm
 231  * Complain about missing quote/regexp/heredoc terminator.
 232  * If it's called with (char *)NULL then it cauterizes the line buffer.
 233  * If we're in a delimited string and the delimiter is a control
 234  * character, it's reformatted into a two-char sequence like ^C.
 235  * This is fatal.
 236  */
 237
 238 STATIC void
 239 S_missingterm(pTHX_ char *s)
 240 {
 241     char tmpbuf[3];
 242     char q;
 243     if (s) {
 244         char *nl = strrchr(s,'\n');
 245         if (nl)
 246             *nl = '\0';
 247     }
 248     else if (
 249 #ifdef EBCDIC
 250         iscntrl(PL_multi_close)
 251 #else
 252         PL_multi_close < 32 || PL_multi_close == 127
 253 #endif
 254         ) {
 255         *tmpbuf = '^';
 256         tmpbuf[1] = toCTRL(PL_multi_close);
 257         s = "\\n";
 258         tmpbuf[2] = '\0';
 259         s = tmpbuf;
 260     }
 261     else {
 262         *tmpbuf = PL_multi_close;
 263         tmpbuf[1] = '\0';
 264         s = tmpbuf;
 265     }
 266     q = strchr(s,'"') ? '\'' : '"';
 267     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 268 }
 269
 270 /*
 271  * Perl_deprecate
 272  */
 273
 274 void
 275 Perl_deprecate(pTHX_ char *s)
 276 {
 277     dTHR;
 278     if (ckWARN(WARN_DEPRECATED))
 279         Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
 280 }
 281
 282 /*
 283  * depcom
 284  * Deprecate a comma-less variable list.
 285  */
 286
 287 STATIC void
 288 S_depcom(pTHX)
 289 {
 290     deprecate("comma-less variable list");
 291 }
 292
 293 /*
 294  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 295  * utf16-to-utf8-reversed.
 296  */
 297
 298 #ifdef PERL_CR_FILTER
 299 static void
 300 strip_return(SV *sv)
 301 {
 302     register char *s = SvPVX(sv);
 303     register char *e = s + SvCUR(sv);
 304     /* outer loop optimized to do nothing if there are no CR-LFs */
 305     while (s < e) {
 306         if (*s++ == '\r' && *s == '\n') {
 307             /* hit a CR-LF, need to copy the rest */
 308             register char *d = s - 1;
 309             *d++ = *s++;
 310             while (s < e) {
 311                 if (*s == '\r' && s[1] == '\n')
 312                     s++;
 313                 *d++ = *s++;
 314             }
 315             SvCUR(sv) -= s - d;
 316             return;
 317         }
 318     }
 319 }
 320
 321 STATIC I32
 322 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 323 {
 324     I32 count = FILTER_READ(idx+1, sv, maxlen);
 325     if (count > 0 && !maxlen)
 326         strip_return(sv);
 327     return count;
 328 }
 329 #endif
 330
 331 /*
 332  * Perl_lex_start
 333  * Initialize variables.  Uses the Perl save_stack to save its state (for
 334  * recursive calls to the parser).
 335  */
 336
 337 void
 338 Perl_lex_start(pTHX_ SV *line)
 339 {
 340     dTHR;
 341     char *s;
 342     STRLEN len;
 343
 344     SAVEI32(PL_lex_dojoin);
 345     SAVEI32(PL_lex_brackets);
 346     SAVEI32(PL_lex_casemods);
 347     SAVEI32(PL_lex_starts);
 348     SAVEI32(PL_lex_state);
 349     SAVEVPTR(PL_lex_inpat);
 350     SAVEI32(PL_lex_inwhat);
 351     if (PL_lex_state == LEX_KNOWNEXT) {
 352         I32 toke = PL_nexttoke;
 353         while (--toke >= 0) {
 354             SAVEI32(PL_nexttype[toke]);
 355             SAVEVPTR(PL_nextval[toke]);
 356         }
 357         SAVEI32(PL_nexttoke);
 358     }
 359     SAVECOPLINE(PL_curcop);
 360     SAVEPPTR(PL_bufptr);
 361     SAVEPPTR(PL_bufend);
 362     SAVEPPTR(PL_oldbufptr);
 363     SAVEPPTR(PL_oldoldbufptr);
 364     SAVEPPTR(PL_linestart);
 365     SAVESPTR(PL_linestr);
 366     SAVEPPTR(PL_lex_brackstack);
 367     SAVEPPTR(PL_lex_casestack);
 368     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
 369     SAVESPTR(PL_lex_stuff);
 370     SAVEI32(PL_lex_defer);
 371     SAVEI32(PL_sublex_info.sub_inwhat);
 372     SAVESPTR(PL_lex_repl);
 373     SAVEINT(PL_expect);
 374     SAVEINT(PL_lex_expect);
 375
 376     PL_lex_state = LEX_NORMAL;
 377     PL_lex_defer = 0;
 378     PL_expect = XSTATE;
 379     PL_lex_brackets = 0;
 380     New(899, PL_lex_brackstack, 120, char);
 381     New(899, PL_lex_casestack, 12, char);
 382     SAVEFREEPV(PL_lex_brackstack);
 383     SAVEFREEPV(PL_lex_casestack);
 384     PL_lex_casemods = 0;
 385     *PL_lex_casestack = '\0';
 386     PL_lex_dojoin = 0;
 387     PL_lex_starts = 0;
 388     PL_lex_stuff = Nullsv;
 389     PL_lex_repl = Nullsv;
 390     PL_lex_inpat = 0;
 391     PL_nexttoke = 0;
 392     PL_lex_inwhat = 0;
 393     PL_sublex_info.sub_inwhat = 0;
 394     PL_linestr = line;
 395     if (SvREADONLY(PL_linestr))
 396         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 397     s = SvPV(PL_linestr, len);
 398     if (len && s[len-1] != ';') {
 399         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
 400             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 401         sv_catpvn(PL_linestr, "\n;", 2);
 402     }
 403     SvTEMP_off(PL_linestr);
 404     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 405     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 406     SvREFCNT_dec(PL_rs);
 407     PL_rs = newSVpvn("\n", 1);
 408     PL_rsfp = 0;
 409 }
 410
 411 /*
 412  * Perl_lex_end
 413  * Finalizer for lexing operations.  Must be called when the parser is
 414  * done with the lexer.
 415  */
 416
 417 void
 418 Perl_lex_end(pTHX)
 419 {
 420     PL_doextract = FALSE;
 421 }
 422
 423 /*
 424  * S_incline
 425  * This subroutine has nothing to do with tilting, whether at windmills
 426  * or pinball tables.  Its name is short for "increment line".  It
 427  * increments the current line number in CopLINE(PL_curcop) and checks
 428  * to see whether the line starts with a comment of the form
 429  *    # line 500 "foo.pm"
 430  * If so, it sets the current line number and file to the values in the comment.
 431  */
 432
 433 STATIC void
 434 S_incline(pTHX_ char *s)
 435 {
 436     dTHR;
 437     char *t;
 438     char *n;
 439     char *e;
 440     char ch;
 441
 442     CopLINE_inc(PL_curcop);
 443     if (*s++ != '#')
 444         return;
 445     while (SPACE_OR_TAB(*s)) s++;
 446     if (strnEQ(s, "line", 4))
 447         s += 4;
 448     else
 449         return;
 450     if (*s == ' ' || *s == '\t')
 451         s++;
 452     else
 453         return;
 454     while (SPACE_OR_TAB(*s)) s++;
 455     if (!isDIGIT(*s))
 456         return;
 457     n = s;
 458     while (isDIGIT(*s))
 459         s++;
 460     while (SPACE_OR_TAB(*s))
 461         s++;
 462     if (*s == '"' && (t = strchr(s+1, '"'))) {
 463         s++;
 464         e = t + 1;
 465     }
 466     else {
 467         for (t = s; !isSPACE(*t); t++) ;
 468         e = t;
 469     }
 470     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 471         e++;
 472     if (*e != '\n' && *e != '\0')
 473         return;         /* false alarm */
 474
 475     ch = *t;
 476     *t = '\0';
 477     if (t - s > 0) {
 478 #ifdef USE_ITHREADS
 479         Safefree(CopFILE(PL_curcop));
 480 #else
 481         SvREFCNT_dec(CopFILEGV(PL_curcop));
 482 #endif
 483         CopFILE_set(PL_curcop, s);
 484     }
 485     *t = ch;
 486     CopLINE_set(PL_curcop, atoi(n)-1);
 487 }
 488
 489 /*
 490  * S_skipspace
 491  * Called to gobble the appropriate amount and type of whitespace.
 492  * Skips comments as well.
 493  */
 494
 495 STATIC char *
 496 S_skipspace(pTHX_ register char *s)
 497 {
 498     dTHR;
 499     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 500         while (s < PL_bufend && SPACE_OR_TAB(*s))
 501             s++;
 502         return s;
 503     }
 504     for (;;) {
 505         STRLEN prevlen;
 506         SSize_t oldprevlen, oldoldprevlen;
 507         SSize_t oldloplen, oldunilen;
 508         while (s < PL_bufend && isSPACE(*s)) {
 509             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
 510                 incline(s);
 511         }
 512
 513         /* comment */
 514         if (s < PL_bufend && *s == '#') {
 515             while (s < PL_bufend && *s != '\n')
 516                 s++;
 517             if (s < PL_bufend) {
 518                 s++;
 519                 if (PL_in_eval && !PL_rsfp) {
 520                     incline(s);
 521                     continue;
 522                 }
 523             }
 524         }
 525
 526         /* only continue to recharge the buffer if we're at the end
 527          * of the buffer, we're not reading from a source filter, and
 528          * we're in normal lexing mode
 529          */
 530         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
 531                 PL_lex_state == LEX_FORMLINE)
 532             return s;
 533
 534         /* try to recharge the buffer */
 535         if ((s = filter_gets(PL_linestr, PL_rsfp,
 536                              (prevlen = SvCUR(PL_linestr)))) == Nullch)
 537         {
 538             /* end of file.  Add on the -p or -n magic */
 539             if (PL_minus_n || PL_minus_p) {
 540                 sv_setpv(PL_linestr,PL_minus_p ?
 541                          ";}continue{print or die qq(-p destination: $!\\n)" :
 542                          "");
 543                 sv_catpv(PL_linestr,";}");
 544                 PL_minus_n = PL_minus_p = 0;
 545             }
 546             else
 547                 sv_setpv(PL_linestr,";");
 548
 549             /* reset variables for next time we lex */
 550             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
 551                 = SvPVX(PL_linestr);
 552             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 553
 554             /* Close the filehandle.  Could be from -P preprocessor,
 555              * STDIN, or a regular file.  If we were reading code from
 556              * STDIN (because the commandline held no -e or filename)
 557              * then we don't close it, we reset it so the code can
 558              * read from STDIN too.
 559              */
 560
 561             if (PL_preprocess && !PL_in_eval)
 562                 (void)PerlProc_pclose(PL_rsfp);
 563             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
 564                 PerlIO_clearerr(PL_rsfp);
 565             else
 566                 (void)PerlIO_close(PL_rsfp);
 567             PL_rsfp = Nullfp;
 568             return s;
 569         }
 570
 571         /* not at end of file, so we only read another line */
 572         /* make corresponding updates to old pointers, for yyerror() */
 573         oldprevlen = PL_oldbufptr - PL_bufend;
 574         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
 575         if (PL_last_uni)
 576             oldunilen = PL_last_uni - PL_bufend;
 577         if (PL_last_lop)
 578             oldloplen = PL_last_lop - PL_bufend;
 579         PL_linestart = PL_bufptr = s + prevlen;
 580         PL_bufend = s + SvCUR(PL_linestr);
 581         s = PL_bufptr;
 582         PL_oldbufptr = s + oldprevlen;
 583         PL_oldoldbufptr = s + oldoldprevlen;
 584         if (PL_last_uni)
 585             PL_last_uni = s + oldunilen;
 586         if (PL_last_lop)
 587             PL_last_lop = s + oldloplen;
 588         incline(s);
 589
 590         /* debugger active and we're not compiling the debugger code,
 591          * so store the line into the debugger's array of lines
 592          */
 593         if (PERLDB_LINE && PL_curstash != PL_debstash) {
 594             SV *sv = NEWSV(85,0);
 595
 596             sv_upgrade(sv, SVt_PVMG);
 597             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
 598             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
 599         }
 600     }
 601 }
 602
 603 /*
 604  * S_check_uni
 605  * Check the unary operators to ensure there's no ambiguity in how they're
 606  * used.  An ambiguous piece of code would be:
 607  *     rand + 5
 608  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
 609  * the +5 is its argument.
 610  */
 611
 612 STATIC void
 613 S_check_uni(pTHX)
 614 {
 615     char *s;
 616     char *t;
 617     dTHR;
 618
 619     if (PL_oldoldbufptr != PL_last_uni)
 620         return;
 621     while (isSPACE(*PL_last_uni))
 622         PL_last_uni++;
 623     for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
 624     if ((t = strchr(s, '(')) && t < PL_bufptr)
 625         return;
 626     if (ckWARN_d(WARN_AMBIGUOUS)){
 627         char ch = *s;
 628         *s = '\0';
 629         Perl_warner(aTHX_ WARN_AMBIGUOUS,
 630                    "Warning: Use of \"%s\" without parens is ambiguous",
 631                    PL_last_uni);
 632         *s = ch;
 633     }
 634 }
 635
 636 /* workaround to replace the UNI() macro with a function.  Only the
 637  * hints/uts.sh file mentions this.  Other comments elsewhere in the
 638  * source indicate Microport Unix might need it too.
 639  */
 640
 641 #ifdef CRIPPLED_CC
 642
 643 #undef UNI
 644 #define UNI(f) return uni(f,s)
 645
 646 STATIC int
 647 S_uni(pTHX_ I32 f, char *s)
 648 {
 649     yylval.ival = f;
 650     PL_expect = XTERM;
 651     PL_bufptr = s;
 652     PL_last_uni = PL_oldbufptr;
 653     PL_last_lop_op = f;
 654     if (*s == '(')
 655         return FUNC1;
 656     s = skipspace(s);
 657     if (*s == '(')
 658         return FUNC1;
 659     else
 660         return UNIOP;
 661 }
 662
 663 #endif /* CRIPPLED_CC */
 664
 665 /*
 666  * LOP : macro to build a list operator.  Its behaviour has been replaced
 667  * with a subroutine, S_lop() for which LOP is just another name.
 668  */
 669
 670 #define LOP(f,x) return lop(f,x,s)
 671
 672 /*
 673  * S_lop
 674  * Build a list operator (or something that might be one).  The rules:
 675  *  - if we have a next token, then it's a list operator [why?]
 676  *  - if the next thing is an opening paren, then it's a function
 677  *  - else it's a list operator
 678  */
 679
 680 STATIC I32
 681 S_lop(pTHX_ I32 f, int x, char *s)
 682 {
 683     dTHR;
 684     yylval.ival = f;
 685     CLINE;
 686     PL_expect = x;
 687     PL_bufptr = s;
 688     PL_last_lop = PL_oldbufptr;
 689     PL_last_lop_op = f;
 690     if (PL_nexttoke)
 691         return LSTOP;
 692     if (*s == '(')
 693         return FUNC;
 694     s = skipspace(s);
 695     if (*s == '(')
 696         return FUNC;
 697     else
 698         return LSTOP;
 699 }
 700
 701 /*
 702  * S_force_next
 703  * When the lexer realizes it knows the next token (for instance,
 704  * it is reordering tokens for the parser) then it can call S_force_next
 705  * to know what token to return the next time the lexer is called.  Caller
 706  * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
 707  * handles the token correctly.
 708  */
 709
 710 STATIC void
 711 S_force_next(pTHX_ I32 type)
 712 {
 713     PL_nexttype[PL_nexttoke] = type;
 714     PL_nexttoke++;
 715     if (PL_lex_state != LEX_KNOWNEXT) {
 716         PL_lex_defer = PL_lex_state;
 717         PL_lex_expect = PL_expect;
 718         PL_lex_state = LEX_KNOWNEXT;
 719     }
 720 }
 721
 722 /*
 723  * S_force_word
 724  * When the lexer knows the next thing is a word (for instance, it has
 725  * just seen -> and it knows that the next char is a word char, then
 726  * it calls S_force_word to stick the next word into the PL_next lookahead.
 727  *
 728  * Arguments:
 729  *   char *start : buffer position (must be within PL_linestr)
 730  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
 731  *   int check_keyword : if true, Perl checks to make sure the word isn't
 732  *       a keyword (do this if the word is a label, e.g. goto FOO)
 733  *   int allow_pack : if true, : characters will also be allowed (require,
 734  *       use, etc. do this)
 735  *   int allow_initial_tick : used by the "sub" lexer only.
 736  */
 737
 738 STATIC char *
 739 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
 740 {
 741     register char *s;
 742     STRLEN len;
 743
 744     start = skipspace(start);
 745     s = start;
 746     if (isIDFIRST_lazy_if(s,UTF) ||
 747         (allow_pack && *s == ':') ||
 748         (allow_initial_tick && *s == '\'') )
 749     {
 750         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
 751         if (check_keyword && keyword(PL_tokenbuf, len))
 752             return start;
 753         if (token == METHOD) {
 754             s = skipspace(s);
 755             if (*s == '(')
 756                 PL_expect = XTERM;
 757             else {
 758                 PL_expect = XOPERATOR;
 759             }
 760         }
 761         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
 762         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
 763         force_next(token);
 764     }
 765     return s;
 766 }
 767
 768 /*
 769  * S_force_ident
 770  * Called when the lexer wants $foo *foo &foo etc, but the program
 771  * text only contains the "foo" portion.  The first argument is a pointer
 772  * to the "foo", and the second argument is the type symbol to prefix.
 773  * Forces the next token to be a "WORD".
 774  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
 775  */
 776
 777 STATIC void
 778 S_force_ident(pTHX_ register char *s, int kind)
 779 {
 780     if (s && *s) {
 781         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
 782         PL_nextval[PL_nexttoke].opval = o;
 783         force_next(WORD);
 784         if (kind) {
 785             dTHR;               /* just for in_eval */
 786             o->op_private = OPpCONST_ENTERED;
 787             /* XXX see note in pp_entereval() for why we forgo typo
 788                warnings if the symbol must be introduced in an eval.
 789                GSAR 96-10-12 */
 790             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
 791                 kind == '$' ? SVt_PV :
 792                 kind == '@' ? SVt_PVAV :
 793                 kind == '%' ? SVt_PVHV :
 794                               SVt_PVGV
 795                 );
 796         }
 797     }
 798 }
 799
 800 NV
 801 Perl_str_to_version(pTHX_ SV *sv)
 802 {
 803     NV retval = 0.0;
 804     NV nshift = 1.0;
 805     STRLEN len;
 806     char *start = SvPVx(sv,len);
 807     bool utf = SvUTF8(sv) ? TRUE : FALSE;
 808     char *end = start + len;
 809     while (start < end) {
 810         STRLEN skip;
 811         UV n;
 812         if (utf)
 813             n = utf8_to_uv((U8*)start, len, &skip, 0);
 814         else {
 815             n = *(U8*)start;
 816             skip = 1;
 817         }
 818         retval += ((NV)n)/nshift;
 819         start += skip;
 820         nshift *= 1000;
 821     }
 822     return retval;
 823 }
 824
 825 /*
 826  * S_force_version
 827  * Forces the next token to be a version number.
 828  */
 829
 830 STATIC char *
 831 S_force_version(pTHX_ char *s)
 832 {
 833     OP *version = Nullop;
 834     char *d;
 835
 836     s = skipspace(s);
 837
 838     d = s;
 839     if (*d == 'v')
 840         d++;
 841     if (isDIGIT(*d)) {
 842         for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++);
 843         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
 844             SV *ver;
 845             s = scan_num(s, &yylval);
 846             version = yylval.opval;
 847             ver = cSVOPx(version)->op_sv;
 848             if (SvPOK(ver) && !SvNIOK(ver)) {
 849                 (void)SvUPGRADE(ver, SVt_PVNV);
 850                 SvNVX(ver) = str_to_version(ver);
 851                 SvNOK_on(ver);          /* hint that it is a version */
 852             }
 853         }
 854     }
 855
 856     /* NOTE: The parser sees the package name and the VERSION swapped */
 857     PL_nextval[PL_nexttoke].opval = version;
 858     force_next(WORD);
 859
 860     return (s);
 861 }
 862
 863 /*
 864  * S_tokeq
 865  * Tokenize a quoted string passed in as an SV.  It finds the next
 866  * chunk, up to end of string or a backslash.  It may make a new
 867  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
 868  * turns \\ into \.
 869  */
 870
 871 STATIC SV *
 872 S_tokeq(pTHX_ SV *sv)
 873 {
 874     register char *s;
 875     register char *send;
 876     register char *d;
 877     STRLEN len = 0;
 878     SV *pv = sv;
 879
 880     if (!SvLEN(sv))
 881         goto finish;
 882
 883     s = SvPV_force(sv, len);
 884     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
 885         goto finish;
 886     send = s + len;
 887     while (s < send && *s != '\\')
 888         s++;
 889     if (s == send)
 890         goto finish;
 891     d = s;
 892     if ( PL_hints & HINT_NEW_STRING )
 893         pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
 894     while (s < send) {
 895         if (*s == '\\') {
 896             if (s + 1 < send && (s[1] == '\\'))
 897                 s++;            /* all that, just for this */
 898         }
 899         *d++ = *s++;
 900     }
 901     *d = '\0';
 902     SvCUR_set(sv, d - SvPVX(sv));
 903   finish:
 904     if ( PL_hints & HINT_NEW_STRING )
 905        return new_constant(NULL, 0, "q", sv, pv, "q");
 906     return sv;
 907 }
 908
 909 /*
 910  * Now come three functions related to double-quote context,
 911  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
 912  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
 913  * interact with PL_lex_state, and create fake ( ... ) argument lists
 914  * to handle functions and concatenation.
 915  * They assume that whoever calls them will be setting up a fake
 916  * join call, because each subthing puts a ',' after it.  This lets
 917  *   "lower \luPpEr"
 918  * become
 919  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
 920  *
 921  * (I'm not sure whether the spurious commas at the end of lcfirst's
 922  * arguments and join's arguments are created or not).
 923  */
 924
 925 /*
 926  * S_sublex_start
 927  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
 928  *
 929  * Pattern matching will set PL_lex_op to the pattern-matching op to
 930  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
 931  *
 932  * OP_CONST and OP_READLINE are easy--just make the new op and return.
 933  *
 934  * Everything else becomes a FUNC.
 935  *
 936  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
 937  * had an OP_CONST or OP_READLINE).  This just sets us up for a
 938  * call to S_sublex_push().
 939  */
 940
 941 STATIC I32
 942 S_sublex_start(pTHX)
 943 {
 944     register I32 op_type = yylval.ival;
 945
 946     if (op_type == OP_NULL) {
 947         yylval.opval = PL_lex_op;
 948         PL_lex_op = Nullop;
 949         return THING;
 950     }
 951     if (op_type == OP_CONST || op_type == OP_READLINE) {
 952         SV *sv = tokeq(PL_lex_stuff);
 953
 954         if (SvTYPE(sv) == SVt_PVIV) {
 955             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
 956             STRLEN len;
 957             char *p;
 958             SV *nsv;
 959
 960             p = SvPV(sv, len);
 961             nsv = newSVpvn(p, len);
 962             if (SvUTF8(sv))
 963                 SvUTF8_on(nsv);
 964             SvREFCNT_dec(sv);
 965             sv = nsv;
 966         }
 967         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
 968         PL_lex_stuff = Nullsv;
 969         return THING;
 970     }
 971
 972     PL_sublex_info.super_state = PL_lex_state;
 973     PL_sublex_info.sub_inwhat = op_type;
 974     PL_sublex_info.sub_op = PL_lex_op;
 975     PL_lex_state = LEX_INTERPPUSH;
 976
 977     PL_expect = XTERM;
 978     if (PL_lex_op) {
 979         yylval.opval = PL_lex_op;
 980         PL_lex_op = Nullop;
 981         return PMFUNC;
 982     }
 983     else
 984         return FUNC;
 985 }
 986
 987 /*
 988  * S_sublex_push
 989  * Create a new scope to save the lexing state.  The scope will be
 990  * ended in S_sublex_done.  Returns a '(', starting the function arguments
 991  * to the uc, lc, etc. found before.
 992  * Sets PL_lex_state to LEX_INTERPCONCAT.
 993  */
 994
 995 STATIC I32
 996 S_sublex_push(pTHX)
 997 {
 998     dTHR;
 999     ENTER;
1000
1001     PL_lex_state = PL_sublex_info.super_state;
1002     SAVEI32(PL_lex_dojoin);
1003     SAVEI32(PL_lex_brackets);
1004     SAVEI32(PL_lex_casemods);
1005     SAVEI32(PL_lex_starts);
1006     SAVEI32(PL_lex_state);
1007     SAVEVPTR(PL_lex_inpat);
1008     SAVEI32(PL_lex_inwhat);
1009     SAVECOPLINE(PL_curcop);
1010     SAVEPPTR(PL_bufptr);
1011     SAVEPPTR(PL_oldbufptr);
1012     SAVEPPTR(PL_oldoldbufptr);
1013     SAVEPPTR(PL_linestart);
1014     SAVESPTR(PL_linestr);
1015     SAVEPPTR(PL_lex_brackstack);
1016     SAVEPPTR(PL_lex_casestack);
1017
1018     PL_linestr = PL_lex_stuff;
1019     PL_lex_stuff = Nullsv;
1020
1021     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1022         = SvPVX(PL_linestr);
1023     PL_bufend += SvCUR(PL_linestr);
1024     SAVEFREESV(PL_linestr);
1025
1026     PL_lex_dojoin = FALSE;
1027     PL_lex_brackets = 0;
1028     New(899, PL_lex_brackstack, 120, char);
1029     New(899, PL_lex_casestack, 12, char);
1030     SAVEFREEPV(PL_lex_brackstack);
1031     SAVEFREEPV(PL_lex_casestack);
1032     PL_lex_casemods = 0;
1033     *PL_lex_casestack = '\0';
1034     PL_lex_starts = 0;
1035     PL_lex_state = LEX_INTERPCONCAT;
1036     CopLINE_set(PL_curcop, PL_multi_start);
1037
1038     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1039     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1040         PL_lex_inpat = PL_sublex_info.sub_op;
1041     else
1042         PL_lex_inpat = Nullop;
1043
1044     return '(';
1045 }
1046
1047 /*
1048  * S_sublex_done
1049  * Restores lexer state after a S_sublex_push.
1050  */
1051
1052 STATIC I32
1053 S_sublex_done(pTHX)
1054 {
1055     if (!PL_lex_starts++) {
1056         PL_expect = XOPERATOR;
1057         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1058         return THING;
1059     }
1060
1061     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1062         PL_lex_state = LEX_INTERPCASEMOD;
1063         return yylex();
1064     }
1065
1066     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1067     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1068         PL_linestr = PL_lex_repl;
1069         PL_lex_inpat = 0;
1070         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1071         PL_bufend += SvCUR(PL_linestr);
1072         SAVEFREESV(PL_linestr);
1073         PL_lex_dojoin = FALSE;
1074         PL_lex_brackets = 0;
1075         PL_lex_casemods = 0;
1076         *PL_lex_casestack = '\0';
1077         PL_lex_starts = 0;
1078         if (SvEVALED(PL_lex_repl)) {
1079             PL_lex_state = LEX_INTERPNORMAL;
1080             PL_lex_starts++;
1081             /*  we don't clear PL_lex_repl here, so that we can check later
1082                 whether this is an evalled subst; that means we rely on the
1083                 logic to ensure sublex_done() is called again only via the
1084                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1085         }
1086         else {
1087             PL_lex_state = LEX_INTERPCONCAT;
1088             PL_lex_repl = Nullsv;
1089         }
1090         return ',';
1091     }
1092     else {
1093         LEAVE;
1094         PL_bufend = SvPVX(PL_linestr);
1095         PL_bufend += SvCUR(PL_linestr);
1096         PL_expect = XOPERATOR;
1097         PL_sublex_info.sub_inwhat = 0;
1098         return ')';
1099     }
1100 }
1101
1102 /*
1103   scan_const
1104
1105   Extracts a pattern, double-quoted string, or transliteration.  This
1106   is terrifying code.
1107
1108   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1109   processing a pattern (PL_lex_inpat is true), a transliteration
1110   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1111
1112   Returns a pointer to the character scanned up to. Iff this is
1113   advanced from the start pointer supplied (ie if anything was
1114   successfully parsed), will leave an OP for the substring scanned
1115   in yylval. Caller must intuit reason for not parsing further
1116   by looking at the next characters herself.
1117
1118   In patterns:
1119     backslashes:
1120       double-quoted style: \r and \n
1121       regexp special ones: \D \s
1122       constants: \x3
1123       backrefs: \1 (deprecated in substitution replacements)
1124       case and quoting: \U \Q \E
1125     stops on @ and $, but not for $ as tail anchor
1126
1127   In transliterations:
1128     characters are VERY literal, except for - not at the start or end
1129     of the string, which indicates a range.  scan_const expands the
1130     range to the full set of intermediate characters.
1131
1132   In double-quoted strings:
1133     backslashes:
1134       double-quoted style: \r and \n
1135       constants: \x3
1136       backrefs: \1 (deprecated)
1137       case and quoting: \U \Q \E
1138     stops on @ and $
1139
1140   scan_const does *not* construct ops to handle interpolated strings.
1141   It stops processing as soon as it finds an embedded $ or @ variable
1142   and leaves it to the caller to work out what's going on.
1143
1144   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1145
1146   $ in pattern could be $foo or could be tail anchor.  Assumption:
1147   it's a tail anchor if $ is the last thing in the string, or if it's
1148   followed by one of ")| \n\t"
1149
1150   \1 (backreferences) are turned into $1
1151
1152   The structure of the code is
1153       while (there's a character to process) {
1154           handle transliteration ranges
1155           skip regexp comments
1156           skip # initiated comments in //x patterns
1157           check for embedded @foo
1158           check for embedded scalars
1159           if (backslash) {
1160               leave intact backslashes from leave (below)
1161               deprecate \1 in strings and sub replacements
1162               handle string-changing backslashes \l \U \Q \E, etc.
1163               switch (what was escaped) {
1164                   handle - in a transliteration (becomes a literal -)
1165                   handle \132 octal characters
1166                   handle 0x15 hex characters
1167                   handle \cV (control V)
1168                   handle printf backslashes (\f, \r, \n, etc)
1169               } (end switch)
1170           } (end if backslash)
1171     } (end while character to read)
1172
1173 */
1174
1175 STATIC char *
1176 S_scan_const(pTHX_ char *start)
1177 {
1178     register char *send = PL_bufend;            /* end of the constant */
1179     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
1180     register char *s = start;                   /* start of the constant */
1181     register char *d = SvPVX(sv);               /* destination for copies */
1182     bool dorange = FALSE;                       /* are we in a translit range? */
1183     bool didrange = FALSE;                      /* did we just finish a range? */
1184     bool has_utf8 = FALSE;                      /* embedded \x{} */
1185     UV uv;
1186
1187     I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1188         ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1189         : UTF;
1190     I32 this_utf8 = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1191         ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1192                                                 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1193         : UTF;
1194     const char *leaveit =       /* set of acceptably-backslashed characters */
1195         PL_lex_inpat
1196             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1197             : "";
1198
1199     while (s < send || dorange) {
1200         /* get transliterations out of the way (they're most literal) */
1201         if (PL_lex_inwhat == OP_TRANS) {
1202             /* expand a range A-Z to the full set of characters.  AIE! */
1203             if (dorange) {
1204                 I32 i;                          /* current expanded character */
1205                 I32 min;                        /* first character in range */
1206                 I32 max;                        /* last character in range */
1207
1208                 i = d - SvPVX(sv);              /* remember current offset */
1209                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1210                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1211                 d -= 2;                         /* eat the first char and the - */
1212
1213                 min = (U8)*d;                   /* first char in range */
1214                 max = (U8)d[1];                 /* last char in range  */
1215
1216                 if (min > max) {
1217                     Perl_croak(aTHX_
1218                                "Invalid [] range \"%c-%c\" in transliteration operator",
1219                                (char)min, (char)max);
1220                 }
1221
1222 #ifndef ASCIIish
1223                 if ((isLOWER(min) && isLOWER(max)) ||
1224                     (isUPPER(min) && isUPPER(max))) {
1225                     if (isLOWER(min)) {
1226                         for (i = min; i <= max; i++)
1227                             if (isLOWER(i))
1228                                 *d++ = i;
1229                     } else {
1230                         for (i = min; i <= max; i++)
1231                             if (isUPPER(i))
1232                                 *d++ = i;
1233                     }
1234                 }
1235                 else
1236 #endif
1237                     for (i = min; i <= max; i++)
1238                         *d++ = i;
1239
1240                 /* mark the range as done, and continue */
1241                 dorange = FALSE;
1242                 didrange = TRUE;
1243                 continue;
1244             }
1245
1246             /* range begins (ignore - as first or last char) */
1247             else if (*s == '-' && s+1 < send  && s != start) {
1248                 if (didrange) {
1249                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1250                 }
1251                 if (utf) {
1252                     *d++ = (char)0xff;  /* use illegal utf8 byte--see pmtrans */
1253                     s++;
1254                     continue;
1255                 }
1256                 dorange = TRUE;
1257                 s++;
1258             }
1259             else {
1260                 didrange = FALSE;
1261             }
1262         }
1263
1264         /* if we get here, we're not doing a transliteration */
1265
1266         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1267            except for the last char, which will be done separately. */
1268         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1269             if (s[2] == '#') {
1270                 while (s < send && *s != ')')
1271                     *d++ = *s++;
1272             }
1273             else if (s[2] == '{' /* This should match regcomp.c */
1274                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1275             {
1276                 I32 count = 1;
1277                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1278                 char c;
1279
1280                 while (count && (c = *regparse)) {
1281                     if (c == '\\' && regparse[1])
1282                         regparse++;
1283                     else if (c == '{')
1284                         count++;
1285                     else if (c == '}')
1286                         count--;
1287                     regparse++;
1288                 }
1289                 if (*regparse != ')') {
1290                     regparse--;         /* Leave one char for continuation. */
1291                     yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1292                 }
1293                 while (s < regparse)
1294                     *d++ = *s++;
1295             }
1296         }
1297
1298         /* likewise skip #-initiated comments in //x patterns */
1299         else if (*s == '#' && PL_lex_inpat &&
1300           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1301             while (s+1 < send && *s != '\n')
1302                 *d++ = *s++;
1303         }
1304
1305         /* check for embedded arrays
1306            (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
1307            */
1308         else if (*s == '@' && s[1]
1309                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1310             break;
1311
1312         /* check for embedded scalars.  only stop if we're sure it's a
1313            variable.
1314         */
1315         else if (*s == '$') {
1316             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1317                 break;
1318             if (s + 1 < send && !strchr("()| \n\t", s[1]))
1319                 break;          /* in regexp, $ might be tail anchor */
1320         }
1321
1322         /* (now in tr/// code again) */
1323
1324         if (*s & 0x80 && this_utf8) {
1325             STRLEN len;
1326             UV uv;
1327
1328             uv = utf8_to_uv((U8*)s, send - s, &len, UTF8_CHECK_ONLY);
1329             if (len == (STRLEN)-1) {
1330                 /* Illegal UTF8 (a high-bit byte), make it valid. */
1331                 char *old_pvx = SvPVX(sv);
1332                 /* need space for one extra char (NOTE: SvCUR() not set here) */
1333                 d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx);
1334                 d = (char*)uv_to_utf8((U8*)d, (U8)*s++);
1335             }
1336             else {
1337                 while (len--)
1338                     *d++ = *s++;
1339             }
1340             has_utf8 = TRUE;
1341             continue;
1342         }
1343
1344         /* backslashes */
1345         if (*s == '\\' && s+1 < send) {
1346             s++;
1347
1348             /* some backslashes we leave behind */
1349             if (*leaveit && *s && strchr(leaveit, *s)) {
1350                 *d++ = '\\';
1351                 *d++ = *s++;
1352                 continue;
1353             }
1354
1355             /* deprecate \1 in strings and substitution replacements */
1356             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1357                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1358             {
1359                 dTHR;                   /* only for ckWARN */
1360                 if (ckWARN(WARN_SYNTAX))
1361                     Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1362                 *--s = '$';
1363                 break;
1364             }
1365
1366             /* string-change backslash escapes */
1367             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1368                 --s;
1369                 break;
1370             }
1371
1372             /* if we get here, it's either a quoted -, or a digit */
1373             switch (*s) {
1374
1375             /* quoted - in transliterations */
1376             case '-':
1377                 if (PL_lex_inwhat == OP_TRANS) {
1378                     *d++ = *s++;
1379                     continue;
1380                 }
1381                 /* FALL THROUGH */
1382             default:
1383                 {
1384                     dTHR;
1385                     if (ckWARN(WARN_MISC) && isALNUM(*s))
1386                         Perl_warner(aTHX_ WARN_MISC,
1387                                "Unrecognized escape \\%c passed through",
1388                                *s);
1389                     /* default action is to copy the quoted character */
1390                     *d++ = *s++;
1391                     continue;
1392                 }
1393
1394             /* \132 indicates an octal constant */
1395             case '0': case '1': case '2': case '3':
1396             case '4': case '5': case '6': case '7':
1397                 {
1398                     STRLEN len = 0;     /* disallow underscores */
1399                     uv = (UV)scan_oct(s, 3, &len);
1400                     s += len;
1401                 }
1402                 goto NUM_ESCAPE_INSERT;
1403
1404             /* \x24 indicates a hex constant */
1405             case 'x':
1406                 ++s;
1407                 if (*s == '{') {
1408                     char* e = strchr(s, '}');
1409                     if (!e) {
1410                         yyerror("Missing right brace on \\x{}");
1411                         e = s;
1412                     }
1413                     else {
1414                         STRLEN len = 1;         /* allow underscores */
1415                         uv = (UV)scan_hex(s + 1, e - s - 1, &len);
1416                         has_utf8 = TRUE;
1417                     }
1418                     s = e + 1;
1419                 }
1420                 else {
1421                     {
1422                         STRLEN len = 0;         /* disallow underscores */
1423                         uv = (UV)scan_hex(s, 2, &len);
1424                         s += len;
1425                     }
1426                 }
1427
1428               NUM_ESCAPE_INSERT:
1429                 /* Insert oct or hex escaped character.
1430                  * There will always enough room in sv since such escapes will
1431                  * be longer than any utf8 sequence they can end up as
1432                  */
1433                 if (uv > 127 || has_utf8) {
1434                     if (!this_utf8 && !has_utf8 && uv > 255) {
1435                         /* might need to recode whatever we have accumulated so far
1436                          * if it contains any hibit chars
1437                          */
1438                         int hicount = 0;
1439                         char *c;
1440                         for (c = SvPVX(sv); c < d; c++) {
1441                             if (*c & 0x80)
1442                                 hicount++;
1443                         }
1444                         if (hicount) {
1445                             char *old_pvx = SvPVX(sv);
1446                             char *src, *dst;
1447                             d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx);
1448
1449                             src = d - 1;
1450                             d += hicount;
1451                             dst = d - 1;
1452
1453                             while (src < dst) {
1454                                 if (*src & 0x80) {
1455                                     dst--;
1456                                     uv_to_utf8((U8*)dst, (U8)*src--);
1457                                     dst--;
1458                                 }
1459                                 else {
1460                                     *dst-- = *src--;
1461                                 }
1462                             }
1463                         }
1464                     }
1465
1466                     if (has_utf8 || uv > 255) {
1467                         d = (char*)uv_to_utf8((U8*)d, uv);
1468                         this_utf8 = TRUE;
1469                     }
1470                     else {
1471                         *d++ = (char)uv;
1472                     }
1473                 }
1474                 else {
1475                     *d++ = (char)uv;
1476                 }
1477                 continue;
1478
1479             /* \N{latin small letter a} is a named character */
1480             case 'N':
1481                 ++s;
1482                 if (*s == '{') {
1483                     char* e = strchr(s, '}');
1484                     SV *res;
1485                     STRLEN len;
1486                     char *str;
1487
1488                     if (!e) {
1489                         yyerror("Missing right brace on \\N{}");
1490                         e = s - 1;
1491                         goto cont_scan;
1492                     }
1493                     res = newSVpvn(s + 1, e - s - 1);
1494                     res = new_constant( Nullch, 0, "charnames",
1495                                         res, Nullsv, "\\N{...}" );
1496                     str = SvPV(res,len);
1497                     if (!has_utf8 && SvUTF8(res)) {
1498                         char *ostart = SvPVX(sv);
1499                         SvCUR_set(sv, d - ostart);
1500                         SvPOK_on(sv);
1501                         *d = '\0';
1502                         sv_utf8_upgrade(sv);
1503                         /* this just broke our allocation above... */
1504                         SvGROW(sv, send - start);
1505                         d = SvPVX(sv) + SvCUR(sv);
1506                         has_utf8 = TRUE;
1507                     }
1508                     if (len > e - s + 4) {
1509                         char *odest = SvPVX(sv);
1510
1511                         SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1512                         d = SvPVX(sv) + (d - odest);
1513                     }
1514                     Copy(str, d, len, char);
1515                     d += len;
1516                     SvREFCNT_dec(res);
1517                   cont_scan:
1518                     s = e + 1;
1519                 }
1520                 else
1521                     yyerror("Missing braces on \\N{}");
1522                 continue;
1523
1524             /* \c is a control character */
1525             case 'c':
1526                 s++;
1527 #ifdef EBCDIC
1528                 *d = *s++;
1529                 if (isLOWER(*d))
1530                    *d = toUPPER(*d);
1531                 *d = toCTRL(*d);
1532                 d++;
1533 #else
1534                 {
1535                     U8 c = *s++;
1536                     *d++ = toCTRL(c);
1537                 }
1538 #endif
1539                 continue;
1540
1541             /* printf-style backslashes, formfeeds, newlines, etc */
1542             case 'b':
1543                 *d++ = '\b';
1544                 break;
1545             case 'n':
1546                 *d++ = '\n';
1547                 break;
1548             case 'r':
1549                 *d++ = '\r';
1550                 break;
1551             case 'f':
1552                 *d++ = '\f';
1553                 break;
1554             case 't':
1555                 *d++ = '\t';
1556                 break;
1557 #ifdef EBCDIC
1558             case 'e':
1559                 *d++ = '\047';  /* CP 1047 */
1560                 break;
1561             case 'a':
1562                 *d++ = '\057';  /* CP 1047 */
1563                 break;
1564 #else
1565             case 'e':
1566                 *d++ = '\033';
1567                 break;
1568             case 'a':
1569                 *d++ = '\007';
1570                 break;
1571 #endif
1572             } /* end switch */
1573
1574             s++;
1575             continue;
1576         } /* end if (backslash) */
1577
1578         *d++ = *s++;
1579     } /* while loop to process each character */
1580
1581     /* terminate the string and set up the sv */
1582     *d = '\0';
1583     SvCUR_set(sv, d - SvPVX(sv));
1584     SvPOK_on(sv);
1585     if (has_utf8)
1586         SvUTF8_on(sv);
1587
1588     /* shrink the sv if we allocated more than we used */
1589     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1590         SvLEN_set(sv, SvCUR(sv) + 1);
1591         Renew(SvPVX(sv), SvLEN(sv), char);
1592     }
1593
1594     /* return the substring (via yylval) only if we parsed anything */
1595     if (s > PL_bufptr) {
1596         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1597             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1598                               sv, Nullsv,
1599                               ( PL_lex_inwhat == OP_TRANS
1600                                 ? "tr"
1601                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1602                                     ? "s"
1603                                     : "qq")));
1604         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1605     } else
1606         SvREFCNT_dec(sv);
1607     return s;
1608 }
1609
1610 /* S_intuit_more
1611  * Returns TRUE if there's more to the expression (e.g., a subscript),
1612  * FALSE otherwise.
1613  *
1614  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1615  *
1616  * ->[ and ->{ return TRUE
1617  * { and [ outside a pattern are always subscripts, so return TRUE
1618  * if we're outside a pattern and it's not { or [, then return FALSE
1619  * if we're in a pattern and the first char is a {
1620  *   {4,5} (any digits around the comma) returns FALSE
1621  * if we're in a pattern and the first char is a [
1622  *   [] returns FALSE
1623  *   [SOMETHING] has a funky algorithm to decide whether it's a
1624  *      character class or not.  It has to deal with things like
1625  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1626  * anything else returns TRUE
1627  */
1628
1629 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1630
1631 STATIC int
1632 S_intuit_more(pTHX_ register char *s)
1633 {
1634     if (PL_lex_brackets)
1635         return TRUE;
1636     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1637         return TRUE;
1638     if (*s != '{' && *s != '[')
1639         return FALSE;
1640     if (!PL_lex_inpat)
1641         return TRUE;
1642
1643     /* In a pattern, so maybe we have {n,m}. */
1644     if (*s == '{') {
1645         s++;
1646         if (!isDIGIT(*s))
1647             return TRUE;
1648         while (isDIGIT(*s))
1649             s++;
1650         if (*s == ',')
1651             s++;
1652         while (isDIGIT(*s))
1653             s++;
1654         if (*s == '}')
1655             return FALSE;
1656         return TRUE;
1657
1658     }
1659
1660     /* On the other hand, maybe we have a character class */
1661
1662     s++;
1663     if (*s == ']' || *s == '^')
1664         return FALSE;
1665     else {
1666         /* this is terrifying, and it works */
1667         int weight = 2;         /* let's weigh the evidence */
1668         char seen[256];
1669         unsigned char un_char = 255, last_un_char;
1670         char *send = strchr(s,']');
1671         char tmpbuf[sizeof PL_tokenbuf * 4];
1672
1673         if (!send)              /* has to be an expression */
1674             return TRUE;
1675
1676         Zero(seen,256,char);
1677         if (*s == '$')
1678             weight -= 3;
1679         else if (isDIGIT(*s)) {
1680             if (s[1] != ']') {
1681                 if (isDIGIT(s[1]) && s[2] == ']')
1682                     weight -= 10;
1683             }
1684             else
1685                 weight -= 100;
1686         }
1687         for (; s < send; s++) {
1688             last_un_char = un_char;
1689             un_char = (unsigned char)*s;
1690             switch (*s) {
1691             case '@':
1692             case '&':
1693             case '$':
1694                 weight -= seen[un_char] * 10;
1695                 if (isALNUM_lazy_if(s+1,UTF)) {
1696                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1697                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1698                         weight -= 100;
1699                     else
1700                         weight -= 10;
1701                 }
1702                 else if (*s == '$' && s[1] &&
1703                   strchr("[#!%*<>()-=",s[1])) {
1704                     if (/*{*/ strchr("])} =",s[2]))
1705                         weight -= 10;
1706                     else
1707                         weight -= 1;
1708                 }
1709                 break;
1710             case '\\':
1711                 un_char = 254;
1712                 if (s[1]) {
1713                     if (strchr("wds]",s[1]))
1714                         weight += 100;
1715                     else if (seen['\''] || seen['"'])
1716                         weight += 1;
1717                     else if (strchr("rnftbxcav",s[1]))
1718                         weight += 40;
1719                     else if (isDIGIT(s[1])) {
1720                         weight += 40;
1721                         while (s[1] && isDIGIT(s[1]))
1722                             s++;
1723                     }
1724                 }
1725                 else
1726                     weight += 100;
1727                 break;
1728             case '-':
1729                 if (s[1] == '\\')
1730                     weight += 50;
1731                 if (strchr("aA01! ",last_un_char))
1732                     weight += 30;
1733                 if (strchr("zZ79~",s[1]))
1734                     weight += 30;
1735                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1736                     weight -= 5;        /* cope with negative subscript */
1737                 break;
1738             default:
1739                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1740                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1741                     char *d = tmpbuf;
1742                     while (isALPHA(*s))
1743                         *d++ = *s++;
1744                     *d = '\0';
1745                     if (keyword(tmpbuf, d - tmpbuf))
1746                         weight -= 150;
1747                 }
1748                 if (un_char == last_un_char + 1)
1749                     weight += 5;
1750                 weight -= seen[un_char];
1751                 break;
1752             }
1753             seen[un_char]++;
1754         }
1755         if (weight >= 0)        /* probably a character class */
1756             return FALSE;
1757     }
1758
1759     return TRUE;
1760 }
1761
1762 /*
1763  * S_intuit_method
1764  *
1765  * Does all the checking to disambiguate
1766  *   foo bar
1767  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
1768  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1769  *
1770  * First argument is the stuff after the first token, e.g. "bar".
1771  *
1772  * Not a method if bar is a filehandle.
1773  * Not a method if foo is a subroutine prototyped to take a filehandle.
1774  * Not a method if it's really "Foo $bar"
1775  * Method if it's "foo $bar"
1776  * Not a method if it's really "print foo $bar"
1777  * Method if it's really "foo package::" (interpreted as package->foo)
1778  * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1779  * Not a method if bar is a filehandle or package, but is quoted with
1780  *   =>
1781  */
1782
1783 STATIC int
1784 S_intuit_method(pTHX_ char *start, GV *gv)
1785 {
1786     char *s = start + (*start == '$');
1787     char tmpbuf[sizeof PL_tokenbuf];
1788     STRLEN len;
1789     GV* indirgv;
1790
1791     if (gv) {
1792         CV *cv;
1793         if (GvIO(gv))
1794             return 0;
1795         if ((cv = GvCVu(gv))) {
1796             char *proto = SvPVX(cv);
1797             if (proto) {
1798                 if (*proto == ';')
1799                     proto++;
1800                 if (*proto == '*')
1801                     return 0;
1802             }
1803         } else
1804             gv = 0;
1805     }
1806     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1807     /* start is the beginning of the possible filehandle/object,
1808      * and s is the end of it
1809      * tmpbuf is a copy of it
1810      */
1811
1812     if (*start == '$') {
1813         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1814             return 0;
1815         s = skipspace(s);
1816         PL_bufptr = start;
1817         PL_expect = XREF;
1818         return *s == '(' ? FUNCMETH : METHOD;
1819     }
1820     if (!keyword(tmpbuf, len)) {
1821         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1822             len -= 2;
1823             tmpbuf[len] = '\0';
1824             goto bare_package;
1825         }
1826         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1827         if (indirgv && GvCVu(indirgv))
1828             return 0;
1829         /* filehandle or package name makes it a method */
1830         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1831             s = skipspace(s);
1832             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1833                 return 0;       /* no assumptions -- "=>" quotes bearword */
1834       bare_package:
1835             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1836                                                    newSVpvn(tmpbuf,len));
1837             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1838             PL_expect = XTERM;
1839             force_next(WORD);
1840             PL_bufptr = s;
1841             return *s == '(' ? FUNCMETH : METHOD;
1842         }
1843     }
1844     return 0;
1845 }
1846
1847 /*
1848  * S_incl_perldb
1849  * Return a string of Perl code to load the debugger.  If PERL5DB
1850  * is set, it will return the contents of that, otherwise a
1851  * compile-time require of perl5db.pl.
1852  */
1853
1854 STATIC char*
1855 S_incl_perldb(pTHX)
1856 {
1857     if (PL_perldb) {
1858         char *pdb = PerlEnv_getenv("PERL5DB");
1859
1860         if (pdb)
1861             return pdb;
1862         SETERRNO(0,SS$_NORMAL);
1863         return "BEGIN { require 'perl5db.pl' }";
1864     }
1865     return "";
1866 }
1867
1868
1869 /* Encoded script support. filter_add() effectively inserts a
1870  * 'pre-processing' function into the current source input stream.
1871  * Note that the filter function only applies to the current source file
1872  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1873  *
1874  * The datasv parameter (which may be NULL) can be used to pass
1875  * private data to this instance of the filter. The filter function
1876  * can recover the SV using the FILTER_DATA macro and use it to
1877  * store private buffers and state information.
1878  *
1879  * The supplied datasv parameter is upgraded to a PVIO type
1880  * and the IoDIRP/IoANY field is used to store the function pointer,
1881  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1882  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1883  * private use must be set using malloc'd pointers.
1884  */
1885
1886 SV *
1887 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1888 {
1889     if (!funcp)
1890         return Nullsv;
1891
1892     if (!PL_rsfp_filters)
1893         PL_rsfp_filters = newAV();
1894     if (!datasv)
1895         datasv = NEWSV(255,0);
1896     if (!SvUPGRADE(datasv, SVt_PVIO))
1897         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1898     IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1899     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1900     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1901                           funcp, SvPV_nolen(datasv)));
1902     av_unshift(PL_rsfp_filters, 1);
1903     av_store(PL_rsfp_filters, 0, datasv) ;
1904     return(datasv);
1905 }
1906
1907
1908 /* Delete most recently added instance of this filter function. */
1909 void
1910 Perl_filter_del(pTHX_ filter_t funcp)
1911 {
1912     SV *datasv;
1913     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1914     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1915         return;
1916     /* if filter is on top of stack (usual case) just pop it off */
1917     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1918     if (IoANY(datasv) == (void *)funcp) {
1919         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1920         IoANY(datasv) = (void *)NULL;
1921         sv_free(av_pop(PL_rsfp_filters));
1922
1923         return;
1924     }
1925     /* we need to search for the correct entry and clear it     */
1926     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1927 }
1928
1929
1930 /* Invoke the n'th filter function for the current rsfp.         */
1931 I32
1932 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1933
1934
1935                         /* 0 = read one text line */
1936 {
1937     filter_t funcp;
1938     SV *datasv = NULL;
1939
1940     if (!PL_rsfp_filters)
1941         return -1;
1942     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
1943         /* Provide a default input filter to make life easy.    */
1944         /* Note that we append to the line. This is handy.      */
1945         DEBUG_P(PerlIO_printf(Perl_debug_log,
1946                               "filter_read %d: from rsfp\n", idx));
1947         if (maxlen) {
1948             /* Want a block */
1949             int len ;
1950             int old_len = SvCUR(buf_sv) ;
1951
1952             /* ensure buf_sv is large enough */
1953             SvGROW(buf_sv, old_len + maxlen) ;
1954             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1955                 if (PerlIO_error(PL_rsfp))
1956                     return -1;          /* error */
1957                 else
1958                     return 0 ;          /* end of file */
1959             }
1960             SvCUR_set(buf_sv, old_len + len) ;
1961         } else {
1962             /* Want a line */
1963             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1964                 if (PerlIO_error(PL_rsfp))
1965                     return -1;          /* error */
1966                 else
1967                     return 0 ;          /* end of file */
1968             }
1969         }
1970         return SvCUR(buf_sv);
1971     }
1972     /* Skip this filter slot if filter has been deleted */
1973     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1974         DEBUG_P(PerlIO_printf(Perl_debug_log,
1975                               "filter_read %d: skipped (filter deleted)\n",
1976                               idx));
1977         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1978     }
1979     /* Get function pointer hidden within datasv        */
1980     funcp = (filter_t)IoANY(datasv);
1981     DEBUG_P(PerlIO_printf(Perl_debug_log,
1982                           "filter_read %d: via function %p (%s)\n",
1983                           idx, funcp, SvPV_nolen(datasv)));
1984     /* Call function. The function is expected to       */
1985     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
1986     /* Return: <0:error, =0:eof, >0:not eof             */
1987     return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1988 }
1989
1990 STATIC char *
1991 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1992 {
1993 #ifdef PERL_CR_FILTER
1994     if (!PL_rsfp_filters) {
1995         filter_add(S_cr_textfilter,NULL);
1996     }
1997 #endif
1998     if (PL_rsfp_filters) {
1999
2000         if (!append)
2001             SvCUR_set(sv, 0);   /* start with empty line        */
2002         if (FILTER_READ(0, sv, 0) > 0)
2003             return ( SvPVX(sv) ) ;
2004         else
2005             return Nullch ;
2006     }
2007     else
2008         return (sv_gets(sv, fp, append));
2009 }
2010
2011 STATIC HV *
2012 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2013 {
2014     GV *gv;
2015
2016     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2017         return PL_curstash;
2018
2019     if (len > 2 &&
2020         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2021         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2022     {
2023         return GvHV(gv);                        /* Foo:: */
2024     }
2025
2026     /* use constant CLASS => 'MyClass' */
2027     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2028         SV *sv;
2029         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2030             pkgname = SvPV_nolen(sv);
2031         }
2032     }
2033
2034     return gv_stashpv(pkgname, FALSE);
2035 }
2036
2037 #ifdef DEBUGGING
2038     static char* exp_name[] =
2039         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2040           "ATTRTERM", "TERMBLOCK"
2041         };
2042 #endif
2043
2044 /*
2045   yylex
2046
2047   Works out what to call the token just pulled out of the input
2048   stream.  The yacc parser takes care of taking the ops we return and
2049   stitching them into a tree.
2050
2051   Returns:
2052     PRIVATEREF
2053
2054   Structure:
2055       if read an identifier
2056           if we're in a my declaration
2057               croak if they tried to say my($foo::bar)
2058               build the ops for a my() declaration
2059           if it's an access to a my() variable
2060               are we in a sort block?
2061                   croak if my($a); $a <=> $b
2062               build ops for access to a my() variable
2063           if in a dq string, and they've said @foo and we can't find @foo
2064               croak
2065           build ops for a bareword
2066       if we already built the token before, use it.
2067 */
2068
2069 #ifdef USE_PURE_BISON
2070 #ifdef __SC__
2071 #pragma segment Perl_yylex_r
2072 #endif
2073 int
2074 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2075 {
2076     dTHR;
2077     int r;
2078
2079     yylval_pointer[yyactlevel] = lvalp;
2080     yychar_pointer[yyactlevel] = lcharp;
2081     yyactlevel++;
2082     if (yyactlevel >= YYMAXLEVEL)
2083         Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2084
2085     r = Perl_yylex(aTHX);
2086
2087     yyactlevel--;
2088
2089     return r;
2090 }
2091 #endif
2092
2093 #ifdef __SC__
2094 #pragma segment Perl_yylex
2095 #endif
2096
2097 int
2098 #ifdef USE_PURE_BISON
2099 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
2100 #else
2101 Perl_yylex(pTHX)
2102 #endif
2103 {
2104     dTHR;
2105     register char *s;
2106     register char *d;
2107     register I32 tmp;
2108     STRLEN len;
2109     GV *gv = Nullgv;
2110     GV **gvp = 0;
2111
2112     /* check if there's an identifier for us to look at */
2113     if (PL_pending_ident) {
2114         /* pit holds the identifier we read and pending_ident is reset */
2115         char pit = PL_pending_ident;
2116         PL_pending_ident = 0;
2117
2118         /* if we're in a my(), we can't allow dynamics here.
2119            $foo'bar has already been turned into $foo::bar, so
2120            just check for colons.
2121
2122            if it's a legal name, the OP is a PADANY.
2123         */
2124         if (PL_in_my) {
2125             if (PL_in_my == KEY_our) {  /* "our" is merely analogous to "my" */
2126                 if (strchr(PL_tokenbuf,':'))
2127                     yyerror(Perl_form(aTHX_ "No package name allowed for "
2128                                       "variable %s in \"our\"",
2129                                       PL_tokenbuf));
2130                 tmp = pad_allocmy(PL_tokenbuf);
2131             }
2132             else {
2133                 if (strchr(PL_tokenbuf,':'))
2134                     yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2135
2136                 yylval.opval = newOP(OP_PADANY, 0);
2137                 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2138                 return PRIVATEREF;
2139             }
2140         }
2141
2142         /*
2143            build the ops for accesses to a my() variable.
2144
2145            Deny my($a) or my($b) in a sort block, *if* $a or $b is
2146            then used in a comparison.  This catches most, but not
2147            all cases.  For instance, it catches
2148                sort { my($a); $a <=> $b }
2149            but not
2150                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2151            (although why you'd do that is anyone's guess).
2152         */
2153
2154         if (!strchr(PL_tokenbuf,':')) {
2155 #ifdef USE_THREADS
2156             /* Check for single character per-thread SVs */
2157             if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2158                 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2159                 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2160             {
2161                 yylval.opval = newOP(OP_THREADSV, 0);
2162                 yylval.opval->op_targ = tmp;
2163                 return PRIVATEREF;
2164             }
2165 #endif /* USE_THREADS */
2166             if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2167                 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2168                 /* might be an "our" variable" */
2169                 if (SvFLAGS(namesv) & SVpad_OUR) {
2170                     /* build ops for a bareword */
2171                     SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2172                     sv_catpvn(sym, "::", 2);
2173                     sv_catpv(sym, PL_tokenbuf+1);
2174                     yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2175                     yylval.opval->op_private = OPpCONST_ENTERED;
2176                     gv_fetchpv(SvPVX(sym),
2177                         (PL_in_eval
2178                             ? (GV_ADDMULTI | GV_ADDINEVAL)
2179                             : TRUE
2180                         ),
2181                         ((PL_tokenbuf[0] == '$') ? SVt_PV
2182                          : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2183                          : SVt_PVHV));
2184                     return WORD;
2185                 }
2186
2187                 /* if it's a sort block and they're naming $a or $b */
2188                 if (PL_last_lop_op == OP_SORT &&
2189                     PL_tokenbuf[0] == '$' &&
2190                     (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2191                     && !PL_tokenbuf[2])
2192                 {
2193                     for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2194                          d < PL_bufend && *d != '\n';
2195                          d++)
2196                     {
2197                         if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2198                             Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2199                                   PL_tokenbuf);
2200                         }
2201                     }
2202                 }
2203
2204                 yylval.opval = newOP(OP_PADANY, 0);
2205                 yylval.opval->op_targ = tmp;
2206                 return PRIVATEREF;
2207             }
2208         }
2209
2210         /*
2211            Whine if they've said @foo in a doublequoted string,
2212            and @foo isn't a variable we can find in the symbol
2213            table.
2214         */
2215         if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2216             GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2217             if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2218                  && ckWARN(WARN_AMBIGUOUS))
2219             {
2220                 /* Downgraded from fatal to warning 20000522 mjd */
2221                 Perl_warner(aTHX_ WARN_AMBIGUOUS,
2222                             "Possible unintended interpolation of %s in string",
2223                              PL_tokenbuf);
2224             }
2225         }
2226
2227         /* build ops for a bareword */
2228         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2229         yylval.opval->op_private = OPpCONST_ENTERED;
2230         gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2231                    ((PL_tokenbuf[0] == '$') ? SVt_PV
2232                     : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2233                     : SVt_PVHV));
2234         return WORD;
2235     }
2236
2237     /* no identifier pending identification */
2238
2239     switch (PL_lex_state) {
2240 #ifdef COMMENTARY
2241     case LEX_NORMAL:            /* Some compilers will produce faster */
2242     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2243         break;
2244 #endif
2245
2246     /* when we've already built the next token, just pull it out of the queue */
2247     case LEX_KNOWNEXT:
2248         PL_nexttoke--;
2249         yylval = PL_nextval[PL_nexttoke];
2250         if (!PL_nexttoke) {
2251             PL_lex_state = PL_lex_defer;
2252             PL_expect = PL_lex_expect;
2253             PL_lex_defer = LEX_NORMAL;
2254         }
2255         return(PL_nexttype[PL_nexttoke]);
2256
2257     /* interpolated case modifiers like \L \U, including \Q and \E.
2258        when we get here, PL_bufptr is at the \
2259     */
2260     case LEX_INTERPCASEMOD:
2261 #ifdef DEBUGGING
2262         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2263             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2264 #endif
2265         /* handle \E or end of string */
2266         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2267             char oldmod;
2268
2269             /* if at a \E */
2270             if (PL_lex_casemods) {
2271                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2272                 PL_lex_casestack[PL_lex_casemods] = '\0';
2273
2274                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2275                     PL_bufptr += 2;
2276                     PL_lex_state = LEX_INTERPCONCAT;
2277                 }
2278                 return ')';
2279             }
2280             if (PL_bufptr != PL_bufend)
2281                 PL_bufptr += 2;
2282             PL_lex_state = LEX_INTERPCONCAT;
2283             return yylex();
2284         }
2285         else {
2286             s = PL_bufptr + 1;
2287             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2288                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
2289             if (strchr("LU", *s) &&
2290                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2291             {
2292                 PL_lex_casestack[--PL_lex_casemods] = '\0';
2293                 return ')';
2294             }
2295             if (PL_lex_casemods > 10) {
2296                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2297                 if (newlb != PL_lex_casestack) {
2298                     SAVEFREEPV(newlb);
2299                     PL_lex_casestack = newlb;
2300                 }
2301             }
2302             PL_lex_casestack[PL_lex_casemods++] = *s;
2303             PL_lex_casestack[PL_lex_casemods] = '\0';
2304             PL_lex_state = LEX_INTERPCONCAT;
2305             PL_nextval[PL_nexttoke].ival = 0;
2306             force_next('(');
2307             if (*s == 'l')
2308                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2309             else if (*s == 'u')
2310                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2311             else if (*s == 'L')
2312                 PL_nextval[PL_nexttoke].ival = OP_LC;
2313             else if (*s == 'U')
2314                 PL_nextval[PL_nexttoke].ival = OP_UC;
2315             else if (*s == 'Q')
2316                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2317             else
2318                 Perl_croak(aTHX_ "panic: yylex");
2319             PL_bufptr = s + 1;
2320             force_next(FUNC);
2321             if (PL_lex_starts) {
2322                 s = PL_bufptr;
2323                 PL_lex_starts = 0;
2324                 Aop(OP_CONCAT);
2325             }
2326             else
2327                 return yylex();
2328         }
2329
2330     case LEX_INTERPPUSH:
2331         return sublex_push();
2332
2333     case LEX_INTERPSTART:
2334         if (PL_bufptr == PL_bufend)
2335             return sublex_done();
2336         PL_expect = XTERM;
2337         PL_lex_dojoin = (*PL_bufptr == '@');
2338         PL_lex_state = LEX_INTERPNORMAL;
2339         if (PL_lex_dojoin) {
2340             PL_nextval[PL_nexttoke].ival = 0;
2341             force_next(',');
2342 #ifdef USE_THREADS
2343             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2344             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2345             force_next(PRIVATEREF);
2346 #else
2347             force_ident("\"", '$');
2348 #endif /* USE_THREADS */
2349             PL_nextval[PL_nexttoke].ival = 0;
2350             force_next('$');
2351             PL_nextval[PL_nexttoke].ival = 0;
2352             force_next('(');
2353             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2354             force_next(FUNC);
2355         }
2356         if (PL_lex_starts++) {
2357             s = PL_bufptr;
2358             Aop(OP_CONCAT);
2359         }
2360         return yylex();
2361
2362     case LEX_INTERPENDMAYBE:
2363         if (intuit_more(PL_bufptr)) {
2364             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2365             break;
2366         }
2367         /* FALL THROUGH */
2368
2369     case LEX_INTERPEND:
2370         if (PL_lex_dojoin) {
2371             PL_lex_dojoin = FALSE;
2372             PL_lex_state = LEX_INTERPCONCAT;
2373             return ')';
2374         }
2375         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2376             && SvEVALED(PL_lex_repl))
2377         {
2378             if (PL_bufptr != PL_bufend)
2379                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2380             PL_lex_repl = Nullsv;
2381         }
2382         /* FALLTHROUGH */
2383     case LEX_INTERPCONCAT:
2384 #ifdef DEBUGGING
2385         if (PL_lex_brackets)
2386             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2387 #endif
2388         if (PL_bufptr == PL_bufend)
2389             return sublex_done();
2390
2391         if (SvIVX(PL_linestr) == '\'') {
2392             SV *sv = newSVsv(PL_linestr);
2393             if (!PL_lex_inpat)
2394                 sv = tokeq(sv);
2395             else if ( PL_hints & HINT_NEW_RE )
2396                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2397             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2398             s = PL_bufend;
2399         }
2400         else {
2401             s = scan_const(PL_bufptr);
2402             if (*s == '\\')
2403                 PL_lex_state = LEX_INTERPCASEMOD;
2404             else
2405                 PL_lex_state = LEX_INTERPSTART;
2406         }
2407
2408         if (s != PL_bufptr) {
2409             PL_nextval[PL_nexttoke] = yylval;
2410             PL_expect = XTERM;
2411             force_next(THING);
2412             if (PL_lex_starts++)
2413                 Aop(OP_CONCAT);
2414             else {
2415                 PL_bufptr = s;
2416                 return yylex();
2417             }
2418         }
2419
2420         return yylex();
2421     case LEX_FORMLINE:
2422         PL_lex_state = LEX_NORMAL;
2423         s = scan_formline(PL_bufptr);
2424         if (!PL_lex_formbrack)
2425             goto rightbracket;
2426         OPERATOR(';');
2427     }
2428
2429     s = PL_bufptr;
2430     PL_oldoldbufptr = PL_oldbufptr;
2431     PL_oldbufptr = s;
2432     DEBUG_p( {
2433         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2434                       exp_name[PL_expect], s);
2435     } )
2436
2437   retry:
2438     switch (*s) {
2439     default:
2440         if (isIDFIRST_lazy_if(s,UTF))
2441             goto keylookup;
2442         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2443     case 4:
2444     case 26:
2445         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2446     case 0:
2447         if (!PL_rsfp) {
2448             PL_last_uni = 0;
2449             PL_last_lop = 0;
2450             if (PL_lex_brackets)
2451                 yyerror("Missing right curly or square bracket");
2452             TOKEN(0);
2453         }
2454         if (s++ < PL_bufend)
2455             goto retry;                 /* ignore stray nulls */
2456         PL_last_uni = 0;
2457         PL_last_lop = 0;
2458         if (!PL_in_eval && !PL_preambled) {
2459             PL_preambled = TRUE;
2460             sv_setpv(PL_linestr,incl_perldb());
2461             if (SvCUR(PL_linestr))
2462                 sv_catpv(PL_linestr,";");
2463             if (PL_preambleav){
2464                 while(AvFILLp(PL_preambleav) >= 0) {
2465                     SV *tmpsv = av_shift(PL_preambleav);
2466                     sv_catsv(PL_linestr, tmpsv);
2467                     sv_catpv(PL_linestr, ";");
2468                     sv_free(tmpsv);
2469                 }
2470                 sv_free((SV*)PL_preambleav);
2471                 PL_preambleav = NULL;
2472             }
2473             if (PL_minus_n || PL_minus_p) {
2474                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2475                 if (PL_minus_l)
2476                     sv_catpv(PL_linestr,"chomp;");
2477                 if (PL_minus_a) {
2478                     GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2479                     if (gv)
2480                         GvIMPORTED_AV_on(gv);
2481                     if (PL_minus_F) {
2482                         if (strchr("/'\"", *PL_splitstr)
2483                               && strchr(PL_splitstr + 1, *PL_splitstr))
2484                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2485                         else {
2486                             char delim;
2487                             s = "'~#\200\1'"; /* surely one char is unused...*/
2488                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2489                             delim = *s;
2490                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2491                                       "q" + (delim == '\''), delim);
2492                             for (s = PL_splitstr; *s; s++) {
2493                                 if (*s == '\\')
2494                                     sv_catpvn(PL_linestr, "\\", 1);
2495                                 sv_catpvn(PL_linestr, s, 1);
2496                             }
2497                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2498                         }
2499                     }
2500                     else
2501                         sv_catpv(PL_linestr,"@F=split(' ');");
2502                 }
2503             }
2504             sv_catpv(PL_linestr, "\n");
2505             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2506             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2507             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2508                 SV *sv = NEWSV(85,0);
2509
2510                 sv_upgrade(sv, SVt_PVMG);
2511                 sv_setsv(sv,PL_linestr);
2512                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2513             }
2514             goto retry;
2515         }
2516         do {
2517             bool bof = PL_rsfp ? TRUE : FALSE;
2518             if (bof) {
2519 #ifdef PERLIO_IS_STDIO
2520 #  ifdef __GNU_LIBRARY__
2521 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2522 #      define FTELL_FOR_PIPE_IS_BROKEN
2523 #    endif
2524 #  else
2525 #    ifdef __GLIBC__
2526 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2527 #        define FTELL_FOR_PIPE_IS_BROKEN
2528 #      endif
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