toke.c

   1 /*    toke.c
   2  *
   3  *    Copyright (c) 1991-1999, 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 static void restore_expect(pTHXo_ void *e);
  32 static void restore_lex_expect(pTHXo_ void *e);
  33
  34 #define UTF (PL_hints & HINT_UTF8)
  35 /*
  36  * Note: we try to be careful never to call the isXXX_utf8() functions
  37  * unless we're pretty sure we've seen the beginning of a UTF-8 character
  38  * (that is, the two high bits are set).  Otherwise we risk loading in the
  39  * heavy-duty SWASHINIT and SWASHGET routines unnecessarily.
  40  */
  41 #define isIDFIRST_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
  42                                 ? isIDFIRST(*(p)) \
  43                                 : isIDFIRST_utf8((U8*)p))
  44 #define isALNUM_lazy(p) ((!UTF || (*((U8*)p) < 0xc0)) \
  45                                 ? isALNUM(*(p)) \
  46                                 : isALNUM_utf8((U8*)p))
  47
  48 /* In variables name $^X, these are the legal values for X.
  49  * 1999-02-27 mjd-perl-patch@plover.com */
  50 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
  51
  52 /* On MacOS, respect nonbreaking spaces */
  53 #ifdef MACOS_TRADITIONAL
  54 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
  55 #else
  56 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
  57 #endif
  58
  59 /* LEX_* are values for PL_lex_state, the state of the lexer.
  60  * They are arranged oddly so that the guard on the switch statement
  61  * can get by with a single comparison (if the compiler is smart enough).
  62  */
  63
  64 /* #define LEX_NOTPARSING               11 is done in perl.h. */
  65
  66 #define LEX_NORMAL              10
  67 #define LEX_INTERPNORMAL         9
  68 #define LEX_INTERPCASEMOD        8
  69 #define LEX_INTERPPUSH           7
  70 #define LEX_INTERPSTART          6
  71 #define LEX_INTERPEND            5
  72 #define LEX_INTERPENDMAYBE       4
  73 #define LEX_INTERPCONCAT         3
  74 #define LEX_INTERPCONST          2
  75 #define LEX_FORMLINE             1
  76 #define LEX_KNOWNEXT             0
  77
  78 #ifdef I_FCNTL
  79 #include <fcntl.h>
  80 #endif
  81 #ifdef I_SYS_FILE
  82 #include <sys/file.h>
  83 #endif
  84
  85 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  86 #ifdef I_UNISTD
  87 #  include <unistd.h> /* Needed for execv() */
  88 #endif
  89
  90
  91 #ifdef ff_next
  92 #undef ff_next
  93 #endif
  94
  95 #ifdef USE_PURE_BISON
  96 YYSTYPE* yylval_pointer = NULL;
  97 int* yychar_pointer = NULL;
  98 #  undef yylval
  99 #  undef yychar
 100 #  define yylval (*yylval_pointer)
 101 #  define yychar (*yychar_pointer)
 102 #  define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
 103 #  undef yylex
 104 #  define yylex()       Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
 105 #endif
 106
 107 #include "keywords.h"
 108
 109 /* CLINE is a macro that ensures PL_copline has a sane value */
 110
 111 #ifdef CLINE
 112 #undef CLINE
 113 #endif
 114 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
 115
 116 /*
 117  * Convenience functions to return different tokens and prime the
 118  * lexer for the next token.  They all take an argument.
 119  *
 120  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
 121  * OPERATOR     : generic operator
 122  * AOPERATOR    : assignment operator
 123  * PREBLOCK     : beginning the block after an if, while, foreach, ...
 124  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
 125  * PREREF       : *EXPR where EXPR is not a simple identifier
 126  * TERM         : expression term
 127  * LOOPX        : loop exiting command (goto, last, dump, etc)
 128  * FTST         : file test operator
 129  * FUN0         : zero-argument function
 130  * FUN1         : not used, except for not, which isn't a UNIOP
 131  * BOop         : bitwise or or xor
 132  * BAop         : bitwise and
 133  * SHop         : shift operator
 134  * PWop         : power operator
 135  * PMop         : pattern-matching operator
 136  * Aop          : addition-level operator
 137  * Mop          : multiplication-level operator
 138  * Eop          : equality-testing operator
 139  * Rop        : relational operator <= != gt
 140  *
 141  * Also see LOP and lop() below.
 142  */
 143
 144 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
 145 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
 146 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
 147 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
 148 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
 149 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
 150 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
 151 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
 152 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
 153 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
 154 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
 155 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
 156 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
 157 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
 158 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
 159 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
 160 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
 161 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
 162 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
 163 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
 164
 165 /* This bit of chicanery makes a unary function followed by
 166  * a parenthesis into a function with one argument, highest precedence.
 167  */
 168 #define UNI(f) return(yylval.ival = f, \
 169         PL_expect = XTERM, \
 170         PL_bufptr = s, \
 171         PL_last_uni = PL_oldbufptr, \
 172         PL_last_lop_op = f, \
 173         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 174
 175 #define UNIBRACK(f) return(yylval.ival = f, \
 176         PL_bufptr = s, \
 177         PL_last_uni = PL_oldbufptr, \
 178         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 179
 180 /* grandfather return to old style */
 181 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 182
 183 /*
 184  * S_ao
 185  *
 186  * This subroutine detects &&= and ||= and turns an ANDAND or OROR
 187  * into an OP_ANDASSIGN or OP_ORASSIGN
 188  */
 189
 190 STATIC int
 191 S_ao(pTHX_ int toketype)
 192 {
 193     if (*PL_bufptr == '=') {
 194         PL_bufptr++;
 195         if (toketype == ANDAND)
 196             yylval.ival = OP_ANDASSIGN;
 197         else if (toketype == OROR)
 198             yylval.ival = OP_ORASSIGN;
 199         toketype = ASSIGNOP;
 200     }
 201     return toketype;
 202 }
 203
 204 /*
 205  * S_no_op
 206  * When Perl expects an operator and finds something else, no_op
 207  * prints the warning.  It always prints "<something> found where
 208  * operator expected.  It prints "Missing semicolon on previous line?"
 209  * if the surprise occurs at the start of the line.  "do you need to
 210  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 211  * where the compiler doesn't know if foo is a method call or a function.
 212  * It prints "Missing operator before end of line" if there's nothing
 213  * after the missing operator, or "... before <...>" if there is something
 214  * after the missing operator.
 215  */
 216
 217 STATIC void
 218 S_no_op(pTHX_ char *what, char *s)
 219 {
 220     char *oldbp = PL_bufptr;
 221     bool is_first = (PL_oldbufptr == PL_linestart);
 222
 223     if (!s)
 224         s = oldbp;
 225     else {
 226         assert(s >= oldbp);
 227         PL_bufptr = s;
 228     }
 229     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 230     if (is_first)
 231         Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
 232     else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
 233         char *t;
 234         for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
 235         if (t < PL_bufptr && isSPACE(*t))
 236             Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
 237                 t - PL_oldoldbufptr, PL_oldoldbufptr);
 238     }
 239     else
 240         Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
 241     PL_bufptr = oldbp;
 242 }
 243
 244 /*
 245  * S_missingterm
 246  * Complain about missing quote/regexp/heredoc terminator.
 247  * If it's called with (char *)NULL then it cauterizes the line buffer.
 248  * If we're in a delimited string and the delimiter is a control
 249  * character, it's reformatted into a two-char sequence like ^C.
 250  * This is fatal.
 251  */
 252
 253 STATIC void
 254 S_missingterm(pTHX_ char *s)
 255 {
 256     char tmpbuf[3];
 257     char q;
 258     if (s) {
 259         char *nl = strrchr(s,'\n');
 260         if (nl)
 261             *nl = '\0';
 262     }
 263     else if (
 264 #ifdef EBCDIC
 265         iscntrl(PL_multi_close)
 266 #else
 267         PL_multi_close < 32 || PL_multi_close == 127
 268 #endif
 269         ) {
 270         *tmpbuf = '^';
 271         tmpbuf[1] = toCTRL(PL_multi_close);
 272         s = "\\n";
 273         tmpbuf[2] = '\0';
 274         s = tmpbuf;
 275     }
 276     else {
 277         *tmpbuf = PL_multi_close;
 278         tmpbuf[1] = '\0';
 279         s = tmpbuf;
 280     }
 281     q = strchr(s,'"') ? '\'' : '"';
 282     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 283 }
 284
 285 /*
 286  * Perl_deprecate
 287  */
 288
 289 void
 290 Perl_deprecate(pTHX_ char *s)
 291 {
 292     dTHR;
 293     if (ckWARN(WARN_DEPRECATED))
 294         Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
 295 }
 296
 297 /*
 298  * depcom
 299  * Deprecate a comma-less variable list.
 300  */
 301
 302 STATIC void
 303 S_depcom(pTHX)
 304 {
 305     deprecate("comma-less variable list");
 306 }
 307
 308 /*
 309  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 310  * utf16-to-utf8-reversed.
 311  */
 312
 313 #ifdef WIN32
 314
 315 STATIC I32
 316 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 317 {
 318  I32 count = FILTER_READ(idx+1, sv, maxlen);
 319  if (count > 0 && !maxlen)
 320   win32_strip_return(sv);
 321  return count;
 322 }
 323 #endif
 324
 325 STATIC I32
 326 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 327 {
 328     I32 count = FILTER_READ(idx+1, sv, maxlen);
 329     if (count) {
 330         U8* tmps;
 331         U8* tend;
 332         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
 333         tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
 334         sv_usepvn(sv, (char*)tmps, tend - tmps);
 335
 336     }
 337     return count;
 338 }
 339
 340 STATIC I32
 341 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 342 {
 343     I32 count = FILTER_READ(idx+1, sv, maxlen);
 344     if (count) {
 345         U8* tmps;
 346         U8* tend;
 347         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
 348         tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
 349         sv_usepvn(sv, (char*)tmps, tend - tmps);
 350
 351     }
 352     return count;
 353 }
 354
 355 /*
 356  * Perl_lex_start
 357  * Initialize variables.  Uses the Perl save_stack to save its state (for
 358  * recursive calls to the parser).
 359  */
 360
 361 void
 362 Perl_lex_start(pTHX_ SV *line)
 363 {
 364     dTHR;
 365     char *s;
 366     STRLEN len;
 367
 368     SAVEI32(PL_lex_dojoin);
 369     SAVEI32(PL_lex_brackets);
 370     SAVEI32(PL_lex_fakebrack);
 371     SAVEI32(PL_lex_casemods);
 372     SAVEI32(PL_lex_starts);
 373     SAVEI32(PL_lex_state);
 374     SAVESPTR(PL_lex_inpat);
 375     SAVEI32(PL_lex_inwhat);
 376     SAVEI16(PL_curcop->cop_line);
 377     SAVEPPTR(PL_bufptr);
 378     SAVEPPTR(PL_bufend);
 379     SAVEPPTR(PL_oldbufptr);
 380     SAVEPPTR(PL_oldoldbufptr);
 381     SAVEPPTR(PL_linestart);
 382     SAVESPTR(PL_linestr);
 383     SAVEPPTR(PL_lex_brackstack);
 384     SAVEPPTR(PL_lex_casestack);
 385     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
 386     SAVESPTR(PL_lex_stuff);
 387     SAVEI32(PL_lex_defer);
 388     SAVEI32(PL_sublex_info.sub_inwhat);
 389     SAVESPTR(PL_lex_repl);
 390     SAVEDESTRUCTOR_X(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
 391     SAVEDESTRUCTOR_X(restore_lex_expect, PL_tokenbuf + PL_expect);
 392
 393     PL_lex_state = LEX_NORMAL;
 394     PL_lex_defer = 0;
 395     PL_expect = XSTATE;
 396     PL_lex_brackets = 0;
 397     PL_lex_fakebrack = 0;
 398     New(899, PL_lex_brackstack, 120, char);
 399     New(899, PL_lex_casestack, 12, char);
 400     SAVEFREEPV(PL_lex_brackstack);
 401     SAVEFREEPV(PL_lex_casestack);
 402     PL_lex_casemods = 0;
 403     *PL_lex_casestack = '\0';
 404     PL_lex_dojoin = 0;
 405     PL_lex_starts = 0;
 406     PL_lex_stuff = Nullsv;
 407     PL_lex_repl = Nullsv;
 408     PL_lex_inpat = 0;
 409     PL_lex_inwhat = 0;
 410     PL_sublex_info.sub_inwhat = 0;
 411     PL_linestr = line;
 412     if (SvREADONLY(PL_linestr))
 413         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 414     s = SvPV(PL_linestr, len);
 415     if (len && s[len-1] != ';') {
 416         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
 417             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 418         sv_catpvn(PL_linestr, "\n;", 2);
 419     }
 420     SvTEMP_off(PL_linestr);
 421     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 422     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 423     SvREFCNT_dec(PL_rs);
 424     PL_rs = newSVpvn("\n", 1);
 425     PL_rsfp = 0;
 426 }
 427
 428 /*
 429  * Perl_lex_end
 430  * Finalizer for lexing operations.  Must be called when the parser is
 431  * done with the lexer.
 432  */
 433
 434 void
 435 Perl_lex_end(pTHX)
 436 {
 437     PL_doextract = FALSE;
 438 }
 439
 440 /*
 441  * S_incline
 442  * This subroutine has nothing to do with tilting, whether at windmills
 443  * or pinball tables.  Its name is short for "increment line".  It
 444  * increments the current line number in PL_curcop->cop_line and checks
 445  * to see whether the line starts with a comment of the form
 446  *    # line 500 "foo.pm"
 447  * If so, it sets the current line number and file to the values in the comment.
 448  */
 449
 450 STATIC void
 451 S_incline(pTHX_ char *s)
 452 {
 453     dTHR;
 454     char *t;
 455     char *n;
 456     char ch;
 457     int sawline = 0;
 458
 459 #ifdef MACOS_TRADITIONAL
 460     MACPERL_DO_ASYNC_TASKS();
 461 #endif
 462     PL_curcop->cop_line++;
 463     if (*s++ != '#')
 464         return;
 465     while (SPACE_OR_TAB(*s)) s++;
 466     if (strnEQ(s, "line ", 5)) {
 467         s += 5;
 468         sawline = 1;
 469     }
 470     if (!isDIGIT(*s))
 471         return;
 472     n = s;
 473     while (isDIGIT(*s))
 474         s++;
 475     while (SPACE_OR_TAB(*s))
 476         s++;
 477     if (*s == '"' && (t = strchr(s+1, '"')))
 478         s++;
 479     else {
 480         if (!sawline)
 481             return;             /* false alarm */
 482         for (t = s; !isSPACE(*t); t++) ;
 483     }
 484     ch = *t;
 485     *t = '\0';
 486     if (t - s > 0)
 487         PL_curcop->cop_filegv = gv_fetchfile(s);
 488     else
 489         PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
 490     *t = ch;
 491     PL_curcop->cop_line = atoi(n)-1;
 492 }
 493
 494 /*
 495  * S_skipspace
 496  * Called to gobble the appropriate amount and type of whitespace.
 497  * Skips comments as well.
 498  */
 499
 500 STATIC char *
 501 S_skipspace(pTHX_ register char *s)
 502 {
 503     dTHR;
 504     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 505         while (s < PL_bufend && SPACE_OR_TAB(*s))
 506             s++;
 507         return s;
 508     }
 509     for (;;) {
 510         STRLEN prevlen;
 511         SSize_t oldprevlen, oldoldprevlen;
 512         SSize_t oldloplen, oldunilen;
 513         while (s < PL_bufend && isSPACE(*s)) {
 514             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
 515                 incline(s);
 516         }
 517
 518         /* comment */
 519         if (s < PL_bufend && *s == '#') {
 520             while (s < PL_bufend && *s != '\n')
 521                 s++;
 522             if (s < PL_bufend) {
 523                 s++;
 524                 if (PL_in_eval && !PL_rsfp) {
 525                     incline(s);
 526                     continue;
 527                 }
 528             }
 529         }
 530
 531         /* only continue to recharge the buffer if we're at the end
 532          * of the buffer, we're not reading from a source filter, and
 533          * we're in normal lexing mode
 534          */
 535         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
 536                 PL_lex_state == LEX_FORMLINE)
 537             return s;
 538
 539         /* try to recharge the buffer */
 540         if ((s = filter_gets(PL_linestr, PL_rsfp,
 541                              (prevlen = SvCUR(PL_linestr)))) == Nullch)
 542         {
 543             /* end of file.  Add on the -p or -n magic */
 544             if (PL_minus_n || PL_minus_p) {
 545                 sv_setpv(PL_linestr,PL_minus_p ?
 546                          ";}continue{print or die qq(-p destination: $!\\n)" :
 547                          "");
 548                 sv_catpv(PL_linestr,";}");
 549                 PL_minus_n = PL_minus_p = 0;
 550             }
 551             else
 552                 sv_setpv(PL_linestr,";");
 553
 554             /* reset variables for next time we lex */
 555             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
 556                 = SvPVX(PL_linestr);
 557             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 558
 559             /* Close the filehandle.  Could be from -P preprocessor,
 560              * STDIN, or a regular file.  If we were reading code from
 561              * STDIN (because the commandline held no -e or filename)
 562              * then we don't close it, we reset it so the code can
 563              * read from STDIN too.
 564              */
 565
 566             if (PL_preprocess && !PL_in_eval)
 567                 (void)PerlProc_pclose(PL_rsfp);
 568             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
 569                 PerlIO_clearerr(PL_rsfp);
 570             else
 571                 (void)PerlIO_close(PL_rsfp);
 572             PL_rsfp = Nullfp;
 573             return s;
 574         }
 575
 576         /* not at end of file, so we only read another line */
 577         /* make corresponding updates to old pointers, for yyerror() */
 578         oldprevlen = PL_oldbufptr - PL_bufend;
 579         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
 580         if (PL_last_uni)
 581             oldunilen = PL_last_uni - PL_bufend;
 582         if (PL_last_lop)
 583             oldloplen = PL_last_lop - PL_bufend;
 584         PL_linestart = PL_bufptr = s + prevlen;
 585         PL_bufend = s + SvCUR(PL_linestr);
 586         s = PL_bufptr;
 587         PL_oldbufptr = s + oldprevlen;
 588         PL_oldoldbufptr = s + oldoldprevlen;
 589         if (PL_last_uni)
 590             PL_last_uni = s + oldunilen;
 591         if (PL_last_lop)
 592             PL_last_lop = s + oldloplen;
 593         incline(s);
 594
 595         /* debugger active and we're not compiling the debugger code,
 596          * so store the line into the debugger's array of lines
 597          */
 598         if (PERLDB_LINE && PL_curstash != PL_debstash) {
 599             SV *sv = NEWSV(85,0);
 600
 601             sv_upgrade(sv, SVt_PVMG);
 602             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
 603             av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
 604         }
 605     }
 606 }
 607
 608 /*
 609  * S_check_uni
 610  * Check the unary operators to ensure there's no ambiguity in how they're
 611  * used.  An ambiguous piece of code would be:
 612  *     rand + 5
 613  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
 614  * the +5 is its argument.
 615  */
 616
 617 STATIC void
 618 S_check_uni(pTHX)
 619 {
 620     char *s;
 621     char *t;
 622     dTHR;
 623
 624     if (PL_oldoldbufptr != PL_last_uni)
 625         return;
 626     while (isSPACE(*PL_last_uni))
 627         PL_last_uni++;
 628     for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
 629     if ((t = strchr(s, '(')) && t < PL_bufptr)
 630         return;
 631     if (ckWARN_d(WARN_AMBIGUOUS)){
 632         char ch = *s;
 633         *s = '\0';
 634         Perl_warner(aTHX_ WARN_AMBIGUOUS,
 635                    "Warning: Use of \"%s\" without parens is ambiguous",
 636                    PL_last_uni);
 637         *s = ch;
 638     }
 639 }
 640
 641 /* workaround to replace the UNI() macro with a function.  Only the
 642  * hints/uts.sh file mentions this.  Other comments elsewhere in the
 643  * source indicate Microport Unix might need it too.
 644  */
 645
 646 #ifdef CRIPPLED_CC
 647
 648 #undef UNI
 649 #define UNI(f) return uni(f,s)
 650
 651 STATIC int
 652 S_uni(pTHX_ I32 f, char *s)
 653 {
 654     yylval.ival = f;
 655     PL_expect = XTERM;
 656     PL_bufptr = s;
 657     PL_last_uni = PL_oldbufptr;
 658     PL_last_lop_op = f;
 659     if (*s == '(')
 660         return FUNC1;
 661     s = skipspace(s);
 662     if (*s == '(')
 663         return FUNC1;
 664     else
 665         return UNIOP;
 666 }
 667
 668 #endif /* CRIPPLED_CC */
 669
 670 /*
 671  * LOP : macro to build a list operator.  Its behaviour has been replaced
 672  * with a subroutine, S_lop() for which LOP is just another name.
 673  */
 674
 675 #define LOP(f,x) return lop(f,x,s)
 676
 677 /*
 678  * S_lop
 679  * Build a list operator (or something that might be one).  The rules:
 680  *  - if we have a next token, then it's a list operator [why?]
 681  *  - if the next thing is an opening paren, then it's a function
 682  *  - else it's a list operator
 683  */
 684
 685 STATIC I32
 686 S_lop(pTHX_ I32 f, expectation x, char *s)
 687 {
 688     dTHR;
 689     yylval.ival = f;
 690     CLINE;
 691     PL_expect = x;
 692     PL_bufptr = s;
 693     PL_last_lop = PL_oldbufptr;
 694     PL_last_lop_op = f;
 695     if (PL_nexttoke)
 696         return LSTOP;
 697     if (*s == '(')
 698         return FUNC;
 699     s = skipspace(s);
 700     if (*s == '(')
 701         return FUNC;
 702     else
 703         return LSTOP;
 704 }
 705
 706 /*
 707  * S_force_next
 708  * When the lexer realizes it knows the next token (for instance,
 709  * it is reordering tokens for the parser) then it can call S_force_next
 710  * to know what token to return the next time the lexer is called.  Caller
 711  * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
 712  * handles the token correctly.
 713  */
 714
 715 STATIC void
 716 S_force_next(pTHX_ I32 type)
 717 {
 718     PL_nexttype[PL_nexttoke] = type;
 719     PL_nexttoke++;
 720     if (PL_lex_state != LEX_KNOWNEXT) {
 721         PL_lex_defer = PL_lex_state;
 722         PL_lex_expect = PL_expect;
 723         PL_lex_state = LEX_KNOWNEXT;
 724     }
 725 }
 726
 727 /*
 728  * S_force_word
 729  * When the lexer knows the next thing is a word (for instance, it has
 730  * just seen -> and it knows that the next char is a word char, then
 731  * it calls S_force_word to stick the next word into the PL_next lookahead.
 732  *
 733  * Arguments:
 734  *   char *start : buffer position (must be within PL_linestr)
 735  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
 736  *   int check_keyword : if true, Perl checks to make sure the word isn't
 737  *       a keyword (do this if the word is a label, e.g. goto FOO)
 738  *   int allow_pack : if true, : characters will also be allowed (require,
 739  *       use, etc. do this)
 740  *   int allow_initial_tick : used by the "sub" lexer only.
 741  */
 742
 743 STATIC char *
 744 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
 745 {
 746     register char *s;
 747     STRLEN len;
 748
 749     start = skipspace(start);
 750     s = start;
 751     if (isIDFIRST_lazy(s) ||
 752         (allow_pack && *s == ':') ||
 753         (allow_initial_tick && *s == '\'') )
 754     {
 755         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
 756         if (check_keyword && keyword(PL_tokenbuf, len))
 757             return start;
 758         if (token == METHOD) {
 759             s = skipspace(s);
 760             if (*s == '(')
 761                 PL_expect = XTERM;
 762             else {
 763                 PL_expect = XOPERATOR;
 764             }
 765         }
 766         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
 767         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
 768         force_next(token);
 769     }
 770     return s;
 771 }
 772
 773 /*
 774  * S_force_ident
 775  * Called when the lexer wants $foo *foo &foo etc, but the program
 776  * text only contains the "foo" portion.  The first argument is a pointer
 777  * to the "foo", and the second argument is the type symbol to prefix.
 778  * Forces the next token to be a "WORD".
 779  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
 780  */
 781
 782 STATIC void
 783 S_force_ident(pTHX_ register char *s, int kind)
 784 {
 785     if (s && *s) {
 786         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
 787         PL_nextval[PL_nexttoke].opval = o;
 788         force_next(WORD);
 789         if (kind) {
 790             dTHR;               /* just for in_eval */
 791             o->op_private = OPpCONST_ENTERED;
 792             /* XXX see note in pp_entereval() for why we forgo typo
 793                warnings if the symbol must be introduced in an eval.
 794                GSAR 96-10-12 */
 795             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
 796                 kind == '$' ? SVt_PV :
 797                 kind == '@' ? SVt_PVAV :
 798                 kind == '%' ? SVt_PVHV :
 799                               SVt_PVGV
 800                 );
 801         }
 802     }
 803 }
 804
 805 /*
 806  * S_force_version
 807  * Forces the next token to be a version number.
 808  */
 809
 810 STATIC char *
 811 S_force_version(pTHX_ char *s)
 812 {
 813     OP *version = Nullop;
 814
 815     s = skipspace(s);
 816
 817     /* default VERSION number -- GBARR */
 818
 819     if(isDIGIT(*s)) {
 820         char *d;
 821         int c;
 822         for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
 823         if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
 824             s = scan_num(s);
 825             /* real VERSION number -- GBARR */
 826             version = yylval.opval;
 827         }
 828     }
 829
 830     /* NOTE: The parser sees the package name and the VERSION swapped */
 831     PL_nextval[PL_nexttoke].opval = version;
 832     force_next(WORD);
 833
 834     return (s);
 835 }
 836
 837 /*
 838  * S_tokeq
 839  * Tokenize a quoted string passed in as an SV.  It finds the next
 840  * chunk, up to end of string or a backslash.  It may make a new
 841  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
 842  * turns \\ into \.
 843  */
 844
 845 STATIC SV *
 846 S_tokeq(pTHX_ SV *sv)
 847 {
 848     register char *s;
 849     register char *send;
 850     register char *d;
 851     STRLEN len = 0;
 852     SV *pv = sv;
 853
 854     if (!SvLEN(sv))
 855         goto finish;
 856
 857     s = SvPV_force(sv, len);
 858     if (SvIVX(sv) == -1)
 859         goto finish;
 860     send = s + len;
 861     while (s < send && *s != '\\')
 862         s++;
 863     if (s == send)
 864         goto finish;
 865     d = s;
 866     if ( PL_hints & HINT_NEW_STRING )
 867         pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
 868     while (s < send) {
 869         if (*s == '\\') {
 870             if (s + 1 < send && (s[1] == '\\'))
 871                 s++;            /* all that, just for this */
 872         }
 873         *d++ = *s++;
 874     }
 875     *d = '\0';
 876     SvCUR_set(sv, d - SvPVX(sv));
 877   finish:
 878     if ( PL_hints & HINT_NEW_STRING )
 879        return new_constant(NULL, 0, "q", sv, pv, "q");
 880     return sv;
 881 }
 882
 883 /*
 884  * Now come three functions related to double-quote context,
 885  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
 886  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
 887  * interact with PL_lex_state, and create fake ( ... ) argument lists
 888  * to handle functions and concatenation.
 889  * They assume that whoever calls them will be setting up a fake
 890  * join call, because each subthing puts a ',' after it.  This lets
 891  *   "lower \luPpEr"
 892  * become
 893  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
 894  *
 895  * (I'm not sure whether the spurious commas at the end of lcfirst's
 896  * arguments and join's arguments are created or not).
 897  */
 898
 899 /*
 900  * S_sublex_start
 901  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
 902  *
 903  * Pattern matching will set PL_lex_op to the pattern-matching op to
 904  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
 905  *
 906  * OP_CONST and OP_READLINE are easy--just make the new op and return.
 907  *
 908  * Everything else becomes a FUNC.
 909  *
 910  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
 911  * had an OP_CONST or OP_READLINE).  This just sets us up for a
 912  * call to S_sublex_push().
 913  */
 914
 915 STATIC I32
 916 S_sublex_start(pTHX)
 917 {
 918     register I32 op_type = yylval.ival;
 919
 920     if (op_type == OP_NULL) {
 921         yylval.opval = PL_lex_op;
 922         PL_lex_op = Nullop;
 923         return THING;
 924     }
 925     if (op_type == OP_CONST || op_type == OP_READLINE) {
 926         SV *sv = tokeq(PL_lex_stuff);
 927
 928         if (SvTYPE(sv) == SVt_PVIV) {
 929             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
 930             STRLEN len;
 931             char *p;
 932             SV *nsv;
 933
 934             p = SvPV(sv, len);
 935             nsv = newSVpvn(p, len);
 936             SvREFCNT_dec(sv);
 937             sv = nsv;
 938         }
 939         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
 940         PL_lex_stuff = Nullsv;
 941         return THING;
 942     }
 943
 944     PL_sublex_info.super_state = PL_lex_state;
 945     PL_sublex_info.sub_inwhat = op_type;
 946     PL_sublex_info.sub_op = PL_lex_op;
 947     PL_lex_state = LEX_INTERPPUSH;
 948
 949     PL_expect = XTERM;
 950     if (PL_lex_op) {
 951         yylval.opval = PL_lex_op;
 952         PL_lex_op = Nullop;
 953         return PMFUNC;
 954     }
 955     else
 956         return FUNC;
 957 }
 958
 959 /*
 960  * S_sublex_push
 961  * Create a new scope to save the lexing state.  The scope will be
 962  * ended in S_sublex_done.  Returns a '(', starting the function arguments
 963  * to the uc, lc, etc. found before.
 964  * Sets PL_lex_state to LEX_INTERPCONCAT.
 965  */
 966
 967 STATIC I32
 968 S_sublex_push(pTHX)
 969 {
 970     dTHR;
 971     ENTER;
 972
 973     PL_lex_state = PL_sublex_info.super_state;
 974     SAVEI32(PL_lex_dojoin);
 975     SAVEI32(PL_lex_brackets);
 976     SAVEI32(PL_lex_fakebrack);
 977     SAVEI32(PL_lex_casemods);
 978     SAVEI32(PL_lex_starts);
 979     SAVEI32(PL_lex_state);
 980     SAVESPTR(PL_lex_inpat);
 981     SAVEI32(PL_lex_inwhat);
 982     SAVEI16(PL_curcop->cop_line);
 983     SAVEPPTR(PL_bufptr);
 984     SAVEPPTR(PL_oldbufptr);
 985     SAVEPPTR(PL_oldoldbufptr);
 986     SAVEPPTR(PL_linestart);
 987     SAVESPTR(PL_linestr);
 988     SAVEPPTR(PL_lex_brackstack);
 989     SAVEPPTR(PL_lex_casestack);
 990
 991     PL_linestr = PL_lex_stuff;
 992     PL_lex_stuff = Nullsv;
 993
 994     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
 995         = SvPVX(PL_linestr);
 996     PL_bufend += SvCUR(PL_linestr);
 997     SAVEFREESV(PL_linestr);
 998
 999     PL_lex_dojoin = FALSE;
1000     PL_lex_brackets = 0;
1001     PL_lex_fakebrack = 0;
1002     New(899, PL_lex_brackstack, 120, char);
1003     New(899, PL_lex_casestack, 12, char);
1004     SAVEFREEPV(PL_lex_brackstack);
1005     SAVEFREEPV(PL_lex_casestack);
1006     PL_lex_casemods = 0;
1007     *PL_lex_casestack = '\0';
1008     PL_lex_starts = 0;
1009     PL_lex_state = LEX_INTERPCONCAT;
1010     PL_curcop->cop_line = PL_multi_start;
1011
1012     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1013     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1014         PL_lex_inpat = PL_sublex_info.sub_op;
1015     else
1016         PL_lex_inpat = Nullop;
1017
1018     return '(';
1019 }
1020
1021 /*
1022  * S_sublex_done
1023  * Restores lexer state after a S_sublex_push.
1024  */
1025
1026 STATIC I32
1027 S_sublex_done(pTHX)
1028 {
1029     if (!PL_lex_starts++) {
1030         PL_expect = XOPERATOR;
1031         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
1032         return THING;
1033     }
1034
1035     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1036         PL_lex_state = LEX_INTERPCASEMOD;
1037         return yylex();
1038     }
1039
1040     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1041     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1042         PL_linestr = PL_lex_repl;
1043         PL_lex_inpat = 0;
1044         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1045         PL_bufend += SvCUR(PL_linestr);
1046         SAVEFREESV(PL_linestr);
1047         PL_lex_dojoin = FALSE;
1048         PL_lex_brackets = 0;
1049         PL_lex_fakebrack = 0;
1050         PL_lex_casemods = 0;
1051         *PL_lex_casestack = '\0';
1052         PL_lex_starts = 0;
1053         if (SvEVALED(PL_lex_repl)) {
1054             PL_lex_state = LEX_INTERPNORMAL;
1055             PL_lex_starts++;
1056             /*  we don't clear PL_lex_repl here, so that we can check later
1057                 whether this is an evalled subst; that means we rely on the
1058                 logic to ensure sublex_done() is called again only via the
1059                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1060         }
1061         else {
1062             PL_lex_state = LEX_INTERPCONCAT;
1063             PL_lex_repl = Nullsv;
1064         }
1065         return ',';
1066     }
1067     else {
1068         LEAVE;
1069         PL_bufend = SvPVX(PL_linestr);
1070         PL_bufend += SvCUR(PL_linestr);
1071         PL_expect = XOPERATOR;
1072         PL_sublex_info.sub_inwhat = 0;
1073         return ')';
1074     }
1075 }
1076
1077 /*
1078   scan_const
1079
1080   Extracts a pattern, double-quoted string, or transliteration.  This
1081   is terrifying code.
1082
1083   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1084   processing a pattern (PL_lex_inpat is true), a transliteration
1085   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1086
1087   Returns a pointer to the character scanned up to. Iff this is
1088   advanced from the start pointer supplied (ie if anything was
1089   successfully parsed), will leave an OP for the substring scanned
1090   in yylval. Caller must intuit reason for not parsing further
1091   by looking at the next characters herself.
1092
1093   In patterns:
1094     backslashes:
1095       double-quoted style: \r and \n
1096       regexp special ones: \D \s
1097       constants: \x3
1098       backrefs: \1 (deprecated in substitution replacements)
1099       case and quoting: \U \Q \E
1100     stops on @ and $, but not for $ as tail anchor
1101
1102   In transliterations:
1103     characters are VERY literal, except for - not at the start or end
1104     of the string, which indicates a range.  scan_const expands the
1105     range to the full set of intermediate characters.
1106
1107   In double-quoted strings:
1108     backslashes:
1109       double-quoted style: \r and \n
1110       constants: \x3
1111       backrefs: \1 (deprecated)
1112       case and quoting: \U \Q \E
1113     stops on @ and $
1114
1115   scan_const does *not* construct ops to handle interpolated strings.
1116   It stops processing as soon as it finds an embedded $ or @ variable
1117   and leaves it to the caller to work out what's going on.
1118
1119   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1120
1121   $ in pattern could be $foo or could be tail anchor.  Assumption:
1122   it's a tail anchor if $ is the last thing in the string, or if it's
1123   followed by one of ")| \n\t"
1124
1125   \1 (backreferences) are turned into $1
1126
1127   The structure of the code is
1128       while (there's a character to process) {
1129           handle transliteration ranges
1130           skip regexp comments
1131           skip # initiated comments in //x patterns
1132           check for embedded @foo
1133           check for embedded scalars
1134           if (backslash) {
1135               leave intact backslashes from leave (below)
1136               deprecate \1 in strings and sub replacements
1137               handle string-changing backslashes \l \U \Q \E, etc.
1138               switch (what was escaped) {
1139                   handle - in a transliteration (becomes a literal -)
1140                   handle \132 octal characters
1141                   handle 0x15 hex characters
1142                   handle \cV (control V)
1143                   handle printf backslashes (\f, \r, \n, etc)
1144               } (end switch)
1145           } (end if backslash)
1146     } (end while character to read)
1147
1148 */
1149
1150 STATIC char *
1151 S_scan_const(pTHX_ char *start)
1152 {
1153     register char *send = PL_bufend;            /* end of the constant */
1154     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
1155     register char *s = start;                   /* start of the constant */
1156     register char *d = SvPVX(sv);               /* destination for copies */
1157     bool dorange = FALSE;                       /* are we in a translit range? */
1158     I32 len;                                    /* ? */
1159     I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1160         ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1161         : UTF;
1162     I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
1163         ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ?
1164                                                 OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
1165         : UTF;
1166     const char *leaveit =       /* set of acceptably-backslashed characters */
1167         PL_lex_inpat
1168             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1169             : "";
1170
1171     while (s < send || dorange) {
1172         /* get transliterations out of the way (they're most literal) */
1173         if (PL_lex_inwhat == OP_TRANS) {
1174             /* expand a range A-Z to the full set of characters.  AIE! */
1175             if (dorange) {
1176                 I32 i;                          /* current expanded character */
1177                 I32 min;                        /* first character in range */
1178                 I32 max;                        /* last character in range */
1179
1180                 i = d - SvPVX(sv);              /* remember current offset */
1181                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1182                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1183                 d -= 2;                         /* eat the first char and the - */
1184
1185                 min = (U8)*d;                   /* first char in range */
1186                 max = (U8)d[1];                 /* last char in range  */
1187
1188 #ifndef ASCIIish
1189                 if ((isLOWER(min) && isLOWER(max)) ||
1190                     (isUPPER(min) && isUPPER(max))) {
1191                     if (isLOWER(min)) {
1192                         for (i = min; i <= max; i++)
1193                             if (isLOWER(i))
1194                                 *d++ = i;
1195                     } else {
1196                         for (i = min; i <= max; i++)
1197                             if (isUPPER(i))
1198                                 *d++ = i;
1199                     }
1200                 }
1201                 else
1202 #endif
1203                     for (i = min; i <= max; i++)
1204                         *d++ = i;
1205
1206                 /* mark the range as done, and continue */
1207                 dorange = FALSE;
1208                 continue;
1209             }
1210
1211             /* range begins (ignore - as first or last char) */
1212             else if (*s == '-' && s+1 < send  && s != start) {
1213                 if (utf) {
1214                     *d++ = (char)0xff;  /* use illegal utf8 byte--see pmtrans */
1215                     s++;
1216                     continue;
1217                 }
1218                 dorange = TRUE;
1219                 s++;
1220             }
1221         }
1222
1223         /* if we get here, we're not doing a transliteration */
1224
1225         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1226            except for the last char, which will be done separately. */
1227         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1228             if (s[2] == '#') {
1229                 while (s < send && *s != ')')
1230                     *d++ = *s++;
1231             } else if (s[2] == '{'
1232                        || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1233                 I32 count = 1;
1234                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1235                 char c;
1236
1237                 while (count && (c = *regparse)) {
1238                     if (c == '\\' && regparse[1])
1239                         regparse++;
1240                     else if (c == '{')
1241                         count++;
1242                     else if (c == '}')
1243                         count--;
1244                     regparse++;
1245                 }
1246                 if (*regparse != ')') {
1247                     regparse--;         /* Leave one char for continuation. */
1248                     yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1249                 }
1250                 while (s < regparse)
1251                     *d++ = *s++;
1252             }
1253         }
1254
1255         /* likewise skip #-initiated comments in //x patterns */
1256         else if (*s == '#' && PL_lex_inpat &&
1257           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1258             while (s+1 < send && *s != '\n')
1259                 *d++ = *s++;
1260         }
1261
1262         /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1263         else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1264             break;
1265
1266         /* check for embedded scalars.  only stop if we're sure it's a
1267            variable.
1268         */
1269         else if (*s == '$') {
1270             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1271                 break;
1272             if (s + 1 < send && !strchr("()| \n\t", s[1]))
1273                 break;          /* in regexp, $ might be tail anchor */
1274         }
1275
1276         /* (now in tr/// code again) */
1277
1278         if (*s & 0x80 && thisutf) {
1279             dTHR;                       /* only for ckWARN */
1280             if (ckWARN(WARN_UTF8)) {
1281                 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1282                 if (len) {
1283                     while (len--)
1284                         *d++ = *s++;
1285                     continue;
1286                 }
1287             }
1288         }
1289
1290         /* backslashes */
1291         if (*s == '\\' && s+1 < send) {
1292             s++;
1293
1294             /* some backslashes we leave behind */
1295             if (*leaveit && *s && strchr(leaveit, *s)) {
1296                 *d++ = '\\';
1297                 *d++ = *s++;
1298                 continue;
1299             }
1300
1301             /* deprecate \1 in strings and substitution replacements */
1302             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1303                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1304             {
1305                 dTHR;                   /* only for ckWARN */
1306                 if (ckWARN(WARN_SYNTAX))
1307                     Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1308                 *--s = '$';
1309                 break;
1310             }
1311
1312             /* string-change backslash escapes */
1313             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1314                 --s;
1315                 break;
1316             }
1317
1318             /* if we get here, it's either a quoted -, or a digit */
1319             switch (*s) {
1320
1321             /* quoted - in transliterations */
1322             case '-':
1323                 if (PL_lex_inwhat == OP_TRANS) {
1324                     *d++ = *s++;
1325                     continue;
1326                 }
1327                 /* FALL THROUGH */
1328             default:
1329                 {
1330                     dTHR;
1331                     if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1332                         Perl_warner(aTHX_ WARN_UNSAFE,
1333                                "Unrecognized escape \\%c passed through",
1334                                *s);
1335                     /* default action is to copy the quoted character */
1336                     *d++ = *s++;
1337                     continue;
1338                 }
1339
1340             /* \132 indicates an octal constant */
1341             case '0': case '1': case '2': case '3':
1342             case '4': case '5': case '6': case '7':
1343                 *d++ = (char)scan_oct(s, 3, &len);
1344                 s += len;
1345                 continue;
1346
1347             /* \x24 indicates a hex constant */
1348             case 'x':
1349                 ++s;
1350                 if (*s == '{') {
1351                     char* e = strchr(s, '}');
1352
1353                     if (!e) {
1354                         yyerror("Missing right brace on \\x{}");
1355                         e = s;
1356                     }
1357                     if (!utf) {
1358                         dTHR;
1359                         if (ckWARN(WARN_UTF8))
1360                             Perl_warner(aTHX_ WARN_UTF8,
1361                                    "Use of \\x{} without utf8 declaration");
1362                     }
1363                     /* note: utf always shorter than hex */
1364                     d = (char*)uv_to_utf8((U8*)d,
1365                                           (UV)scan_hex(s + 1, e - s - 1, &len));
1366                     s = e + 1;
1367                 }
1368                 else {
1369                     UV uv = (UV)scan_hex(s, 2, &len);
1370                     if (utf && PL_lex_inwhat == OP_TRANS &&
1371                         utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1372                     {
1373                         d = (char*)uv_to_utf8((U8*)d, uv);      /* doing a CU or UC */
1374                     }
1375                     else {
1376                         if (uv >= 127 && UTF) {
1377                             dTHR;
1378                             if (ckWARN(WARN_UTF8))
1379                                 Perl_warner(aTHX_ WARN_UTF8,
1380                                     "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1381                                     len,s,len,s);
1382                         }
1383                         *d++ = (char)uv;
1384                     }
1385                     s += len;
1386                 }
1387                 continue;
1388
1389             /* \N{latin small letter a} is a named character */
1390             case 'N':
1391                 ++s;
1392                 if (*s == '{') {
1393                     char* e = strchr(s, '}');
1394                     HV *hv;
1395                     SV **svp;
1396                     SV *res, *cv;
1397                     STRLEN len;
1398                     char *str;
1399                     char *why = Nullch;
1400
1401                     if (!e) {
1402                         yyerror("Missing right brace on \\N{}");
1403                         e = s - 1;
1404                         goto cont_scan;
1405                     }
1406                     res = newSVpvn(s + 1, e - s - 1);
1407                     res = new_constant( Nullch, 0, "charnames",
1408                                         res, Nullsv, "\\N{...}" );
1409                     str = SvPV(res,len);
1410                     if (len > e - s + 4) {
1411                         char *odest = SvPVX(sv);
1412
1413                         SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1414                         d = SvPVX(sv) + (d - odest);
1415                     }
1416                     Copy(str, d, len, char);
1417                     d += len;
1418                     SvREFCNT_dec(res);
1419                   cont_scan:
1420                     s = e + 1;
1421                 }
1422                 else
1423                     yyerror("Missing braces on \\N{}");
1424                 continue;
1425
1426             /* \c is a control character */
1427             case 'c':
1428                 s++;
1429 #ifdef EBCDIC
1430                 *d = *s++;
1431                 if (isLOWER(*d))
1432                    *d = toUPPER(*d);
1433                 *d++ = toCTRL(*d);
1434 #else
1435                 len = *s++;
1436                 *d++ = toCTRL(len);
1437 #endif
1438                 continue;
1439
1440             /* printf-style backslashes, formfeeds, newlines, etc */
1441             case 'b':
1442                 *d++ = '\b';
1443                 break;
1444             case 'n':
1445                 *d++ = '\n';
1446                 break;
1447             case 'r':
1448                 *d++ = '\r';
1449                 break;
1450             case 'f':
1451                 *d++ = '\f';
1452                 break;
1453             case 't':
1454                 *d++ = '\t';
1455                 break;
1456 #ifdef EBCDIC
1457             case 'e':
1458                 *d++ = '\047';  /* CP 1047 */
1459                 break;
1460             case 'a':
1461                 *d++ = '\057';  /* CP 1047 */
1462                 break;
1463 #else
1464             case 'e':
1465                 *d++ = '\033';
1466                 break;
1467             case 'a':
1468                 *d++ = '\007';
1469                 break;
1470 #endif
1471             } /* end switch */
1472
1473             s++;
1474             continue;
1475         } /* end if (backslash) */
1476
1477         *d++ = *s++;
1478     } /* while loop to process each character */
1479
1480     /* terminate the string and set up the sv */
1481     *d = '\0';
1482     SvCUR_set(sv, d - SvPVX(sv));
1483     SvPOK_on(sv);
1484
1485     /* shrink the sv if we allocated more than we used */
1486     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1487         SvLEN_set(sv, SvCUR(sv) + 1);
1488         Renew(SvPVX(sv), SvLEN(sv), char);
1489     }
1490
1491     /* return the substring (via yylval) only if we parsed anything */
1492     if (s > PL_bufptr) {
1493         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1494             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1495                               sv, Nullsv,
1496                               ( PL_lex_inwhat == OP_TRANS
1497                                 ? "tr"
1498                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1499                                     ? "s"
1500                                     : "qq")));
1501         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1502     } else
1503         SvREFCNT_dec(sv);
1504     return s;
1505 }
1506
1507 /* S_intuit_more
1508  * Returns TRUE if there's more to the expression (e.g., a subscript),
1509  * FALSE otherwise.
1510  *
1511  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1512  *
1513  * ->[ and ->{ return TRUE
1514  * { and [ outside a pattern are always subscripts, so return TRUE
1515  * if we're outside a pattern and it's not { or [, then return FALSE
1516  * if we're in a pattern and the first char is a {
1517  *   {4,5} (any digits around the comma) returns FALSE
1518  * if we're in a pattern and the first char is a [
1519  *   [] returns FALSE
1520  *   [SOMETHING] has a funky algorithm to decide whether it's a
1521  *      character class or not.  It has to deal with things like
1522  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1523  * anything else returns TRUE
1524  */
1525
1526 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1527
1528 STATIC int
1529 S_intuit_more(pTHX_ register char *s)
1530 {
1531     if (PL_lex_brackets)
1532         return TRUE;
1533     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1534         return TRUE;
1535     if (*s != '{' && *s != '[')
1536         return FALSE;
1537     if (!PL_lex_inpat)
1538         return TRUE;
1539
1540     /* In a pattern, so maybe we have {n,m}. */
1541     if (*s == '{') {
1542         s++;
1543         if (!isDIGIT(*s))
1544             return TRUE;
1545         while (isDIGIT(*s))
1546             s++;
1547         if (*s == ',')
1548             s++;
1549         while (isDIGIT(*s))
1550             s++;
1551         if (*s == '}')
1552             return FALSE;
1553         return TRUE;
1554
1555     }
1556
1557     /* On the other hand, maybe we have a character class */
1558
1559     s++;
1560     if (*s == ']' || *s == '^')
1561         return FALSE;
1562     else {
1563         /* this is terrifying, and it works */
1564         int weight = 2;         /* let's weigh the evidence */
1565         char seen[256];
1566         unsigned char un_char = 255, last_un_char;
1567         char *send = strchr(s,']');
1568         char tmpbuf[sizeof PL_tokenbuf * 4];
1569
1570         if (!send)              /* has to be an expression */
1571             return TRUE;
1572
1573         Zero(seen,256,char);
1574         if (*s == '$')
1575             weight -= 3;
1576         else if (isDIGIT(*s)) {
1577             if (s[1] != ']') {
1578                 if (isDIGIT(s[1]) && s[2] == ']')
1579                     weight -= 10;
1580             }
1581             else
1582                 weight -= 100;
1583         }
1584         for (; s < send; s++) {
1585             last_un_char = un_char;
1586             un_char = (unsigned char)*s;
1587             switch (*s) {
1588             case '@':
1589             case '&':
1590             case '$':
1591                 weight -= seen[un_char] * 10;
1592                 if (isALNUM_lazy(s+1)) {
1593                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1594                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1595                         weight -= 100;
1596                     else
1597                         weight -= 10;
1598                 }
1599                 else if (*s == '$' && s[1] &&
1600                   strchr("[#!%*<>()-=",s[1])) {
1601                     if (/*{*/ strchr("])} =",s[2]))
1602                         weight -= 10;
1603                     else
1604                         weight -= 1;
1605                 }
1606                 break;
1607             case '\\':
1608                 un_char = 254;
1609                 if (s[1]) {
1610                     if (strchr("wds]",s[1]))
1611                         weight += 100;
1612                     else if (seen['\''] || seen['"'])
1613                         weight += 1;
1614                     else if (strchr("rnftbxcav",s[1]))
1615                         weight += 40;
1616                     else if (isDIGIT(s[1])) {
1617                         weight += 40;
1618                         while (s[1] && isDIGIT(s[1]))
1619                             s++;
1620                     }
1621                 }
1622                 else
1623                     weight += 100;
1624                 break;
1625             case '-':
1626                 if (s[1] == '\\')
1627                     weight += 50;
1628                 if (strchr("aA01! ",last_un_char))
1629                     weight += 30;
1630                 if (strchr("zZ79~",s[1]))
1631                     weight += 30;
1632                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1633                     weight -= 5;        /* cope with negative subscript */
1634                 break;
1635             default:
1636                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1637                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1638                     char *d = tmpbuf;
1639                     while (isALPHA(*s))
1640                         *d++ = *s++;
1641                     *d = '\0';
1642                     if (keyword(tmpbuf, d - tmpbuf))
1643                         weight -= 150;
1644                 }
1645                 if (un_char == last_un_char + 1)
1646                     weight += 5;
1647                 weight -= seen[un_char];
1648                 break;
1649             }
1650             seen[un_char]++;
1651         }
1652         if (weight >= 0)        /* probably a character class */
1653             return FALSE;
1654     }
1655
1656     return TRUE;
1657 }
1658
1659 /*
1660  * S_intuit_method
1661  *
1662  * Does all the checking to disambiguate
1663  *   foo bar
1664  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
1665  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1666  *
1667  * First argument is the stuff after the first token, e.g. "bar".
1668  *
1669  * Not a method if bar is a filehandle.
1670  * Not a method if foo is a subroutine prototyped to take a filehandle.
1671  * Not a method if it's really "Foo $bar"
1672  * Method if it's "foo $bar"
1673  * Not a method if it's really "print foo $bar"
1674  * Method if it's really "foo package::" (interpreted as package->foo)
1675  * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1676  * Not a method if bar is a filehandle or package, but is quotd with
1677  *   =>
1678  */
1679
1680 STATIC int
1681 S_intuit_method(pTHX_ char *start, GV *gv)
1682 {
1683     char *s = start + (*start == '$');
1684     char tmpbuf[sizeof PL_tokenbuf];
1685     STRLEN len;
1686     GV* indirgv;
1687
1688     if (gv) {
1689         CV *cv;
1690         if (GvIO(gv))
1691             return 0;
1692         if ((cv = GvCVu(gv))) {
1693             char *proto = SvPVX(cv);
1694             if (proto) {
1695                 if (*proto == ';')
1696                     proto++;
1697                 if (*proto == '*')
1698                     return 0;
1699             }
1700         } else
1701             gv = 0;
1702     }
1703     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1704     /* start is the beginning of the possible filehandle/object,
1705      * and s is the end of it
1706      * tmpbuf is a copy of it
1707      */
1708
1709     if (*start == '$') {
1710         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1711             return 0;
1712         s = skipspace(s);
1713         PL_bufptr = start;
1714         PL_expect = XREF;
1715         return *s == '(' ? FUNCMETH : METHOD;
1716     }
1717     if (!keyword(tmpbuf, len)) {
1718         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1719             len -= 2;
1720             tmpbuf[len] = '\0';
1721             goto bare_package;
1722         }
1723         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1724         if (indirgv && GvCVu(indirgv))
1725             return 0;
1726         /* filehandle or package name makes it a method */
1727         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1728             s = skipspace(s);
1729             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1730                 return 0;       /* no assumptions -- "=>" quotes bearword */
1731       bare_package:
1732             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1733                                                    newSVpvn(tmpbuf,len));
1734             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1735             PL_expect = XTERM;
1736             force_next(WORD);
1737             PL_bufptr = s;
1738             return *s == '(' ? FUNCMETH : METHOD;
1739         }
1740     }
1741     return 0;
1742 }
1743
1744 /*
1745  * S_incl_perldb
1746  * Return a string of Perl code to load the debugger.  If PERL5DB
1747  * is set, it will return the contents of that, otherwise a
1748  * compile-time require of perl5db.pl.
1749  */
1750
1751 STATIC char*
1752 S_incl_perldb(pTHX)
1753 {
1754     if (PL_perldb) {
1755         char *pdb = PerlEnv_getenv("PERL5DB");
1756
1757         if (pdb)
1758             return pdb;
1759         SETERRNO(0,SS$_NORMAL);
1760         return "BEGIN { require 'perl5db.pl' }";
1761     }
1762     return "";
1763 }
1764
1765
1766 /* Encoded script support. filter_add() effectively inserts a
1767  * 'pre-processing' function into the current source input stream.
1768  * Note that the filter function only applies to the current source file
1769  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1770  *
1771  * The datasv parameter (which may be NULL) can be used to pass
1772  * private data to this instance of the filter. The filter function
1773  * can recover the SV using the FILTER_DATA macro and use it to
1774  * store private buffers and state information.
1775  *
1776  * The supplied datasv parameter is upgraded to a PVIO type
1777  * and the IoDIRP field is used to store the function pointer.
1778  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1779  * private use must be set using malloc'd pointers.
1780  */
1781
1782 SV *
1783 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1784 {
1785     if (!funcp)
1786         return Nullsv;
1787
1788     if (!PL_rsfp_filters)
1789         PL_rsfp_filters = newAV();
1790     if (!datasv)
1791         datasv = NEWSV(255,0);
1792     if (!SvUPGRADE(datasv, SVt_PVIO))
1793         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1794     IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1795     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1796                           funcp, SvPV_nolen(datasv)));
1797     av_unshift(PL_rsfp_filters, 1);
1798     av_store(PL_rsfp_filters, 0, datasv) ;
1799     return(datasv);
1800 }
1801
1802
1803 /* Delete most recently added instance of this filter function. */
1804 void
1805 Perl_filter_del(pTHX_ filter_t funcp)
1806 {
1807     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1808     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1809         return;
1810     /* if filter is on top of stack (usual case) just pop it off */
1811     if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1812         IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1813         sv_free(av_pop(PL_rsfp_filters));
1814
1815         return;
1816     }
1817     /* we need to search for the correct entry and clear it     */
1818     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1819 }
1820
1821
1822 /* Invoke the n'th filter function for the current rsfp.         */
1823 I32
1824 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1825
1826
1827                         /* 0 = read one text line */
1828 {
1829     filter_t funcp;
1830     SV *datasv = NULL;
1831
1832     if (!PL_rsfp_filters)
1833         return -1;
1834     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
1835         /* Provide a default input filter to make life easy.    */
1836         /* Note that we append to the line. This is handy.      */
1837         DEBUG_P(PerlIO_printf(Perl_debug_log,
1838                               "filter_read %d: from rsfp\n", idx));
1839         if (maxlen) {
1840             /* Want a block */
1841             int len ;
1842             int old_len = SvCUR(buf_sv) ;
1843
1844             /* ensure buf_sv is large enough */
1845             SvGROW(buf_sv, old_len + maxlen) ;
1846             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1847                 if (PerlIO_error(PL_rsfp))
1848                     return -1;          /* error */
1849                 else
1850                     return 0 ;          /* end of file */
1851             }
1852             SvCUR_set(buf_sv, old_len + len) ;
1853         } else {
1854             /* Want a line */
1855             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1856                 if (PerlIO_error(PL_rsfp))
1857                     return -1;          /* error */
1858                 else
1859                     return 0 ;          /* end of file */
1860             }
1861         }
1862         return SvCUR(buf_sv);
1863     }
1864     /* Skip this filter slot if filter has been deleted */
1865     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1866         DEBUG_P(PerlIO_printf(Perl_debug_log,
1867                               "filter_read %d: skipped (filter deleted)\n",
1868                               idx));
1869         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1870     }
1871     /* Get function pointer hidden within datasv        */
1872     funcp = (filter_t)IoDIRP(datasv);
1873     DEBUG_P(PerlIO_printf(Perl_debug_log,
1874                           "filter_read %d: via function %p (%s)\n",
1875                           idx, funcp, SvPV_nolen(datasv)));
1876     /* Call function. The function is expected to       */
1877     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
1878     /* Return: <0:error, =0:eof, >0:not eof             */
1879     return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1880 }
1881
1882 STATIC char *
1883 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1884 {
1885 #ifdef WIN32FILTER
1886     if (!PL_rsfp_filters) {
1887         filter_add(win32_textfilter,NULL);
1888     }
1889 #endif
1890     if (PL_rsfp_filters) {
1891
1892         if (!append)
1893             SvCUR_set(sv, 0);   /* start with empty line        */
1894         if (FILTER_READ(0, sv, 0) > 0)
1895             return ( SvPVX(sv) ) ;
1896         else
1897             return Nullch ;
1898     }
1899     else
1900         return (sv_gets(sv, fp, append));
1901 }
1902
1903
1904 #ifdef DEBUGGING
1905     static char* exp_name[] =
1906         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1907           "ATTRTERM", "TERMBLOCK"
1908         };
1909 #endif
1910
1911 /*
1912   yylex
1913
1914   Works out what to call the token just pulled out of the input
1915   stream.  The yacc parser takes care of taking the ops we return and
1916   stitching them into a tree.
1917
1918   Returns:
1919     PRIVATEREF
1920
1921   Structure:
1922       if read an identifier
1923           if we're in a my declaration
1924               croak if they tried to say my($foo::bar)
1925               build the ops for a my() declaration
1926           if it's an access to a my() variable
1927               are we in a sort block?
1928                   croak if my($a); $a <=> $b
1929               build ops for access to a my() variable
1930           if in a dq string, and they've said @foo and we can't find @foo
1931               croak
1932           build ops for a bareword
1933       if we already built the token before, use it.
1934 */
1935
1936 int
1937 #ifdef USE_PURE_BISON
1938 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1939 #else
1940 Perl_yylex(pTHX)
1941 #endif
1942 {
1943     dTHR;
1944     register char *s;
1945     register char *d;
1946     register I32 tmp;
1947     STRLEN len;
1948     GV *gv = Nullgv;
1949     GV **gvp = 0;
1950
1951 #ifdef USE_PURE_BISON
1952     yylval_pointer = lvalp;
1953     yychar_pointer = lcharp;
1954 #endif
1955
1956     /* check if there's an identifier for us to look at */
1957     if (PL_pending_ident) {
1958         /* pit holds the identifier we read and pending_ident is reset */
1959         char pit = PL_pending_ident;
1960         PL_pending_ident = 0;
1961
1962         /* if we're in a my(), we can't allow dynamics here.
1963            $foo'bar has already been turned into $foo::bar, so
1964            just check for colons.
1965
1966            if it's a legal name, the OP is a PADANY.
1967         */
1968         if (PL_in_my) {
1969             if (PL_in_my == KEY_our) {  /* "our" is merely analogous to "my" */
1970                 tmp = pad_allocmy(PL_tokenbuf);
1971             }
1972             else {
1973                 if (strchr(PL_tokenbuf,':'))
1974                     yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1975
1976                 yylval.opval = newOP(OP_PADANY, 0);
1977                 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1978                 return PRIVATEREF;
1979             }
1980         }
1981
1982         /*
1983            build the ops for accesses to a my() variable.
1984
1985            Deny my($a) or my($b) in a sort block, *if* $a or $b is
1986            then used in a comparison.  This catches most, but not
1987            all cases.  For instance, it catches
1988                sort { my($a); $a <=> $b }
1989            but not
1990                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1991            (although why you'd do that is anyone's guess).
1992         */
1993
1994         if (!strchr(PL_tokenbuf,':')) {
1995 #ifdef USE_THREADS
1996             /* Check for single character per-thread SVs */
1997             if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1998                 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1999                 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2000             {
2001                 yylval.opval = newOP(OP_THREADSV, 0);
2002                 yylval.opval->op_targ = tmp;
2003                 return PRIVATEREF;
2004             }
2005 #endif /* USE_THREADS */
2006             if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2007                 /* might be an "our" variable" */
2008                 if (SvFLAGS(AvARRAY(PL_comppad_name)[tmp]) & SVpad_OUR) {
2009                     /* build ops for a bareword */
2010                     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2011                     yylval.opval->op_private = OPpCONST_ENTERED;
2012                     gv_fetchpv(PL_tokenbuf+1,
2013                         (PL_in_eval
2014                             ? (GV_ADDMULTI | GV_ADDINEVAL | GV_ADDOUR)
2015                             : GV_ADDOUR
2016                         ),
2017                         ((PL_tokenbuf[0] == '$') ? SVt_PV
2018                          : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2019                          : SVt_PVHV));
2020                     return WORD;
2021                 }
2022
2023                 /* if it's a sort block and they're naming $a or $b */
2024                 if (PL_last_lop_op == OP_SORT &&
2025                     PL_tokenbuf[0] == '$' &&
2026                     (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2027                     && !PL_tokenbuf[2])
2028                 {
2029                     for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2030                          d < PL_bufend && *d != '\n';
2031                          d++)
2032                     {
2033                         if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2034                             Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2035                                   PL_tokenbuf);
2036                         }
2037                     }
2038                 }
2039
2040                 yylval.opval = newOP(OP_PADANY, 0);
2041                 yylval.opval->op_targ = tmp;
2042                 return PRIVATEREF;
2043             }
2044         }
2045
2046         /*
2047            Whine if they've said @foo in a doublequoted string,
2048            and @foo isn't a variable we can find in the symbol
2049            table.
2050         */
2051         if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2052             GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2053             if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2054                 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
2055                              PL_tokenbuf, PL_tokenbuf));
2056         }
2057
2058         /* build ops for a bareword */
2059         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2060         yylval.opval->op_private = OPpCONST_ENTERED;
2061         gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2062                    ((PL_tokenbuf[0] == '$') ? SVt_PV
2063                     : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2064                     : SVt_PVHV));
2065         return WORD;
2066     }
2067
2068     /* no identifier pending identification */
2069
2070     switch (PL_lex_state) {
2071 #ifdef COMMENTARY
2072     case LEX_NORMAL:            /* Some compilers will produce faster */
2073     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2074         break;
2075 #endif
2076
2077     /* when we've already built the next token, just pull it out of the queue */
2078     case LEX_KNOWNEXT:
2079         PL_nexttoke--;
2080         yylval = PL_nextval[PL_nexttoke];
2081         if (!PL_nexttoke) {
2082             PL_lex_state = PL_lex_defer;
2083             PL_expect = PL_lex_expect;
2084             PL_lex_defer = LEX_NORMAL;
2085         }
2086         return(PL_nexttype[PL_nexttoke]);
2087
2088     /* interpolated case modifiers like \L \U, including \Q and \E.
2089        when we get here, PL_bufptr is at the \
2090     */
2091     case LEX_INTERPCASEMOD:
2092 #ifdef DEBUGGING
2093         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2094             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2095 #endif
2096         /* handle \E or end of string */
2097         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2098             char oldmod;
2099
2100             /* if at a \E */
2101             if (PL_lex_casemods) {
2102                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2103                 PL_lex_casestack[PL_lex_casemods] = '\0';
2104
2105                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2106                     PL_bufptr += 2;
2107                     PL_lex_state = LEX_INTERPCONCAT;
2108                 }
2109                 return ')';
2110             }
2111             if (PL_bufptr != PL_bufend)
2112                 PL_bufptr += 2;
2113             PL_lex_state = LEX_INTERPCONCAT;
2114             return yylex();
2115         }
2116         else {
2117             s = PL_bufptr + 1;
2118             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2119                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
2120             if (strchr("LU", *s) &&
2121                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2122             {
2123                 PL_lex_casestack[--PL_lex_casemods] = '\0';
2124                 return ')';
2125             }
2126             if (PL_lex_casemods > 10) {
2127                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2128                 if (newlb != PL_lex_casestack) {
2129                     SAVEFREEPV(newlb);
2130                     PL_lex_casestack = newlb;
2131                 }
2132             }
2133             PL_lex_casestack[PL_lex_casemods++] = *s;
2134             PL_lex_casestack[PL_lex_casemods] = '\0';
2135             PL_lex_state = LEX_INTERPCONCAT;
2136             PL_nextval[PL_nexttoke].ival = 0;
2137             force_next('(');
2138             if (*s == 'l')
2139                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2140             else if (*s == 'u')
2141                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2142             else if (*s == 'L')
2143                 PL_nextval[PL_nexttoke].ival = OP_LC;
2144             else if (*s == 'U')
2145                 PL_nextval[PL_nexttoke].ival = OP_UC;
2146             else if (*s == 'Q')
2147                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2148             else
2149                 Perl_croak(aTHX_ "panic: yylex");
2150             PL_bufptr = s + 1;
2151             force_next(FUNC);
2152             if (PL_lex_starts) {
2153                 s = PL_bufptr;
2154                 PL_lex_starts = 0;
2155                 Aop(OP_CONCAT);
2156             }
2157             else
2158                 return yylex();
2159         }
2160
2161     case LEX_INTERPPUSH:
2162         return sublex_push();
2163
2164     case LEX_INTERPSTART:
2165         if (PL_bufptr == PL_bufend)
2166             return sublex_done();
2167         PL_expect = XTERM;
2168         PL_lex_dojoin = (*PL_bufptr == '@');
2169         PL_lex_state = LEX_INTERPNORMAL;
2170         if (PL_lex_dojoin) {
2171             PL_nextval[PL_nexttoke].ival = 0;
2172             force_next(',');
2173 #ifdef USE_THREADS
2174             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2175             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2176             force_next(PRIVATEREF);
2177 #else
2178             force_ident("\"", '$');
2179 #endif /* USE_THREADS */
2180             PL_nextval[PL_nexttoke].ival = 0;
2181             force_next('$');
2182             PL_nextval[PL_nexttoke].ival = 0;
2183             force_next('(');
2184             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2185             force_next(FUNC);
2186         }
2187         if (PL_lex_starts++) {
2188             s = PL_bufptr;
2189             Aop(OP_CONCAT);
2190         }
2191         return yylex();
2192
2193     case LEX_INTERPENDMAYBE:
2194         if (intuit_more(PL_bufptr)) {
2195             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2196             break;
2197         }
2198         /* FALL THROUGH */
2199
2200     case LEX_INTERPEND:
2201         if (PL_lex_dojoin) {
2202             PL_lex_dojoin = FALSE;
2203             PL_lex_state = LEX_INTERPCONCAT;
2204             return ')';
2205         }
2206         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2207             && SvEVALED(PL_lex_repl))
2208         {
2209             if (PL_bufptr != PL_bufend)
2210                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2211             PL_lex_repl = Nullsv;
2212         }
2213         /* FALLTHROUGH */
2214     case LEX_INTERPCONCAT:
2215 #ifdef DEBUGGING
2216         if (PL_lex_brackets)
2217             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2218 #endif
2219         if (PL_bufptr == PL_bufend)
2220             return sublex_done();
2221
2222         if (SvIVX(PL_linestr) == '\'') {
2223             SV *sv = newSVsv(PL_linestr);
2224             if (!PL_lex_inpat)
2225                 sv = tokeq(sv);
2226             else if ( PL_hints & HINT_NEW_RE )
2227                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2228             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2229             s = PL_bufend;
2230         }
2231         else {
2232             s = scan_const(PL_bufptr);
2233             if (*s == '\\')
2234                 PL_lex_state = LEX_INTERPCASEMOD;
2235             else
2236                 PL_lex_state = LEX_INTERPSTART;
2237         }
2238
2239         if (s != PL_bufptr) {
2240             PL_nextval[PL_nexttoke] = yylval;
2241             PL_expect = XTERM;
2242             force_next(THING);
2243             if (PL_lex_starts++)
2244                 Aop(OP_CONCAT);
2245             else {
2246                 PL_bufptr = s;
2247                 return yylex();
2248             }
2249         }
2250
2251         return yylex();
2252     case LEX_FORMLINE:
2253         PL_lex_state = LEX_NORMAL;
2254         s = scan_formline(PL_bufptr);
2255         if (!PL_lex_formbrack)
2256             goto rightbracket;
2257         OPERATOR(';');
2258     }
2259
2260     s = PL_bufptr;
2261     PL_oldoldbufptr = PL_oldbufptr;
2262     PL_oldbufptr = s;
2263     DEBUG_p( {
2264         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2265                       exp_name[PL_expect], s);
2266     } )
2267
2268   retry:
2269     switch (*s) {
2270     default:
2271         if (isIDFIRST_lazy(s))
2272             goto keylookup;
2273         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2274     case 4:
2275     case 26:
2276         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2277     case 0:
2278         if (!PL_rsfp) {
2279             PL_last_uni = 0;
2280             PL_last_lop = 0;
2281             if (PL_lex_brackets)
2282                 yyerror("Missing right curly or square bracket");
2283             TOKEN(0);
2284         }
2285         if (s++ < PL_bufend)
2286             goto retry;                 /* ignore stray nulls */
2287         PL_last_uni = 0;
2288         PL_last_lop = 0;
2289         if (!PL_in_eval && !PL_preambled) {
2290             PL_preambled = TRUE;
2291             sv_setpv(PL_linestr,incl_perldb());
2292             if (SvCUR(PL_linestr))
2293                 sv_catpv(PL_linestr,";");
2294             if (PL_preambleav){
2295                 while(AvFILLp(PL_preambleav) >= 0) {
2296                     SV *tmpsv = av_shift(PL_preambleav);
2297                     sv_catsv(PL_linestr, tmpsv);
2298                     sv_catpv(PL_linestr, ";");
2299                     sv_free(tmpsv);
2300                 }
2301                 sv_free((SV*)PL_preambleav);
2302                 PL_preambleav = NULL;
2303             }
2304             if (PL_minus_n || PL_minus_p) {
2305                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2306                 if (PL_minus_l)
2307                     sv_catpv(PL_linestr,"chomp;");
2308                 if (PL_minus_a) {
2309                     GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2310                     if (gv)
2311                         GvIMPORTED_AV_on(gv);
2312                     if (PL_minus_F) {
2313                         if (strchr("/'\"", *PL_splitstr)
2314                               && strchr(PL_splitstr + 1, *PL_splitstr))
2315                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2316                         else {
2317                             char delim;
2318                             s = "'~#\200\1'"; /* surely one char is unused...*/
2319                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2320                             delim = *s;
2321                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2322                                       "q" + (delim == '\''), delim);
2323                             for (s = PL_splitstr; *s; s++) {
2324                                 if (*s == '\\')
2325                                     sv_catpvn(PL_linestr, "\\", 1);
2326                                 sv_catpvn(PL_linestr, s, 1);
2327                             }
2328                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2329                         }
2330                     }
2331                     else
2332                         sv_catpv(PL_linestr,"@F=split(' ');");
2333                 }
2334             }
2335             sv_catpv(PL_linestr, "\n");
2336             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2337             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2338             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2339                 SV *sv = NEWSV(85,0);
2340
2341                 sv_upgrade(sv, SVt_PVMG);
2342                 sv_setsv(sv,PL_linestr);
2343                 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2344             }
2345             goto retry;
2346         }
2347         do {
2348             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2349               fake_eof:
2350                 if (PL_rsfp) {
2351                     if (PL_preprocess && !PL_in_eval)
2352                         (void)PerlProc_pclose(PL_rsfp);
2353                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2354                         PerlIO_clearerr(PL_rsfp);
2355                     else
2356                         (void)PerlIO_close(PL_rsfp);
2357                     PL_rsfp = Nullfp;
2358                     PL_doextract = FALSE;
2359                 }
2360                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2361                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2362                     sv_catpv(PL_linestr,";}");
2363                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2364                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2365                     PL_minus_n = PL_minus_p = 0;
2366                     goto retry;
2367                 }
2368                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2369                 sv_setpv(PL_linestr,"");
2370                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2371             }
2372             if (PL_doextract) {
2373                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2374                     PL_doextract = FALSE;
2375
2376                 /* Incest with pod. */
2377                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2378                     sv_setpv(PL_linestr, "");
2379                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2380                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2381                     PL_doextract = FALSE;
2382                 }
2383             }
2384             incline(s);
2385         } while (PL_doextract);
2386         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2387         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2388             SV *sv = NEWSV(85,0);
2389
2390             sv_upgrade(sv, SVt_PVMG);
2391             sv_setsv(sv,PL_linestr);
2392             av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2393         }
2394         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2395         if (PL_curcop->cop_line == 1) {
2396             while (s < PL_bufend && isSPACE(*s))
2397                 s++;
2398             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2399                 s++;
2400             d = Nullch;
2401             if (!PL_in_eval) {
2402                 if (*s == '#' && *(s+1) == '!')
2403                     d = s + 2;
2404 #ifdef ALTERNATE_SHEBANG
2405                 else {
2406                     static char as[] = ALTERNATE_SHEBANG;
2407                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2408                         d = s + (sizeof(as) - 1);
2409                 }
2410 #endif /* ALTERNATE_SHEBANG */
2411             }
2412             if (d) {
2413                 char *ipath;
2414                 char *ipathend;
2415
2416                 while (isSPACE(*d))
2417                     d++;
2418                 ipath = d;
2419                 while (*d && !isSPACE(*d))
2420                     d++;
2421                 ipathend = d;
2422
2423 #ifdef ARG_ZERO_IS_SCRIPT
2424                 if (ipathend > ipath) {
2425                     /*
2426                      * HP-UX (at least) sets argv[0] to the script name,
2427                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2428                      * at least, set argv[0] to the basename of the Perl
2429                      * interpreter. So, having found "#!", we'll set it right.
2430                      */
2431                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2432                     assert(SvPOK(x) || SvGMAGICAL(x));
2433                     if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2434                         sv_setpvn(x, ipath, ipathend - ipath);
2435                         SvSETMAGIC(x);
2436                     }
2437                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2438                 }
2439 #endif /* ARG_ZERO_IS_SCRIPT */
2440
2441                 /*
2442                  * Look for options.
2443                  */
2444                 d = instr(s,"perl -");
2445                 if (!d) {
2446                     d = instr(s,"perl");
2447 #if defined(DOSISH)
2448                     /* avoid getting into infinite loops when shebang
2449                      * line contains "Perl" rather than "perl" */
2450                     if (!d) {
2451                         for (d = ipathend-4; d >= ipath; --d) {
2452                             if ((*d == 'p' || *d == 'P')
2453                                 && !ibcmp(d, "perl", 4))
2454                             {
2455                                 break;
2456                             }
2457                         }
2458                         if (d < ipath)
2459                             d = Nullch;
2460                     }
2461 #endif
2462                 }
2463 #ifdef ALTERNATE_SHEBANG
2464                 /*
2465                  * If the ALTERNATE_SHEBANG on this system starts with a
2466                  * character that can be part of a Perl expression, then if
2467                  * we see it but not "perl", we're probably looking at the
2468                  * start of Perl code, not a request to hand off to some
2469                  * other interpreter.  Similarly, if "perl" is there, but
2470                  * not in the first 'word' of the line, we assume the line
2471                  * contains the start of the Perl program.
2472                  */
2473                 if (d && *s != '#') {
2474                     char *c = ipath;
2475                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2476                         c++;
2477                     if (c < d)
2478                         d = Nullch;     /* "perl" not in first word; ignore */
2479                     else
2480                         *s = '#';       /* Don't try to parse shebang line */
2481                 }
2482 #endif /* ALTERNATE_SHEBANG */
2483 #ifndef MACOS_TRADITIONAL
2484                 if (!d &&
2485                     *s == '#' &&
2486                     ipathend > ipath &&
2487                     !PL_minus_c &&
2488                     !instr(s,"indir") &&
2489                     instr(PL_origargv[0],"perl"))
2490                 {
2491                     char **newargv;
2492
2493                     *ipathend = '\0';
2494                     s = ipathend + 1;
2495                     while (s < PL_bufend && isSPACE(*s))
2496                         s++;
2497                     if (s < PL_bufend) {
2498                         Newz(899,newargv,PL_origargc+3,char*);
2499                         newargv[1] = s;
2500                         while (s < PL_bufend && !isSPACE(*s))
2501                             s++;
2502                         *s = '\0';
2503                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2504                     }
2505                     else
2506                         newargv = PL_origargv;
2507                     newargv[0] = ipath;
2508                     PerlProc_execv(ipath, newargv);
2509                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2510                 }
2511 #endif
2512                 if (d) {
2513                     U32 oldpdb = PL_perldb;
2514                     bool oldn = PL_minus_n;
2515                     bool oldp = PL_minus_p;
2516
2517                     while (*d && !isSPACE(*d)) d++;
2518                     while (SPACE_OR_TAB(*d)) d++;
2519
2520                     if (*d++ == '-') {
2521                         do {
2522                             if (*d == 'M' || *d == 'm') {
2523                                 char *m = d;
2524                                 while (*d && !isSPACE(*d)) d++;
2525                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2526                                       (int)(d - m), m);
2527                             }
2528                             d = moreswitches(d);
2529                         } while (d);
2530                         if (PERLDB_LINE && !oldpdb ||
2531                             ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2532                               /* if we have already added "LINE: while (<>) {",
2533                                  we must not do it again */
2534                         {
2535                             sv_setpv(PL_linestr, "");
2536                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2537                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2538                             PL_preambled = FALSE;
2539                             if (PERLDB_LINE)
2540                                 (void)gv_fetchfile(PL_origfilename);
2541                             goto retry;
2542                         }
2543                     }
2544                 }
2545             }
2546         }
2547         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2548             PL_bufptr = s;
2549             PL_lex_state = LEX_FORMLINE;
2550             return yylex();
2551         }
2552         goto retry;
2553     case '\r':
2554 #ifdef PERL_STRICT_CR
2555         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2556         Perl_croak(aTHX_
2557       "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2558 #endif
2559     case ' ': case '\t': case '\f': case 013:
2560 #ifdef MACOS_TRADITIONAL
2561     case '\312':
2562 #endif
2563         s++;
2564         goto retry;
2565     case '#':
2566     case '\n':
2567         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2568             d = PL_bufend;
2569             while (s < d && *s != '\n')
2570                 s++;
2571             if (s < d)
2572                 s++;
2573             incline(s);
2574             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2575                 PL_bufptr = s;
2576                 PL_lex_state = LEX_FORMLINE;
2577                 return yylex();
2578             }
2579         }
2580         else {
2581             *s = '\0';
2582             PL_bufend = s;
2583         }
2584         goto retry;
2585     case '-':
2586         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2587             s++;
2588             PL_bufptr = s;
2589             tmp = *s++;
2590
2591             while (s < PL_bufend && SPACE_OR_TAB(*s))
2592                 s++;
2593
2594             if (strnEQ(s,"=>",2)) {
2595                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2596                 OPERATOR('-');          /* unary minus */
2597             }
2598             PL_last_uni = PL_oldbufptr;
2599             PL_last_lop_op = OP_FTEREAD;        /* good enough */
2600             switch (tmp) {
2601             case 'r': FTST(OP_FTEREAD);
2602             case 'w': FTST(OP_FTEWRITE);
2603             case 'x': FTST(OP_FTEEXEC);
2604             case 'o': FTST(OP_FTEOWNED);
2605             case 'R': FTST(OP_FTRREAD);
2606             case 'W': FTST(OP_FTRWRITE);
2607             case 'X': FTST(OP_FTREXEC);
2608             case 'O': FTST(OP_FTROWNED);
2609             case 'e': FTST(OP_FTIS);
2610             case 'z': FTST(OP_FTZERO);
2611             case 's': FTST(OP_FTSIZE);
2612             case 'f': FTST(OP_FTFILE);
2613             case 'd': FTST(OP_FTDIR);
2614             case 'l': FTST(OP_FTLINK);
2615             case 'p': FTST(OP_FTPIPE);
2616             case 'S': FTST(OP_FTSOCK);
2617             case 'u': FTST(OP_FTSUID);
2618             case 'g': FTST(OP_FTSGID);
2619             case 'k': FTST(OP_FTSVTX);
2620             case 'b': FTST(OP_FTBLK);
2621             case 'c': FTST(OP_FTCHR);
2622             case 't': FTST(OP_FTTTY);
2623             case 'T': FTST(OP_FTTEXT);
2624             case 'B': FTST(OP_FTBINARY);
2625             case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2626             case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2627             case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2628             default:
2629                 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2630                 break;
2631             }
2632         }
2633         tmp = *s++;
2634         if (*s == tmp) {
2635             s++;
2636             if (PL_expect == XOPERATOR)
2637                 TERM(POSTDEC);
2638             else
2639                 OPERATOR(PREDEC);
2640         }
2641         else if (*s == '>') {
2642             s++;
2643             s = skipspace(s);
2644             if (isIDFIRST_lazy(s)) {
2645                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2646                 TOKEN(ARROW);
2647             }
2648             else if (*s == '$')
2649                 OPERATOR(ARROW);
2650             else
2651                 TERM(ARROW);
2652         }
2653         if (PL_expect == XOPERATOR)
2654             Aop(OP_SUBTRACT);
2655         else {
2656             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2657                 check_uni();
2658             OPERATOR('-');              /* unary minus */
2659         }
2660
2661     case '+':
2662         tmp = *s++;
2663         if (*s == tmp) {
2664             s++;
2665             if (PL_expect == XOPERATOR)
2666                 TERM(POSTINC);
2667             else
2668                 OPERATOR(PREINC);
2669         }
2670         if (PL_expect == XOPERATOR)
2671             Aop(OP_ADD);
2672         else {
2673             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2674                 check_uni();
2675             OPERATOR('+');
2676         }
2677
2678     case '*':
2679         if (PL_expect != XOPERATOR) {
2680             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2681             PL_expect = XOPERATOR;
2682             force_ident(PL_tokenbuf, '*');
2683             if (!*PL_tokenbuf)
2684                 PREREF('*');
2685             TERM('*');
2686         }
2687         s++;
2688         if (*s == '*') {
2689             s++;
2690             PWop(OP_POW);
2691         }
2692         Mop(OP_MULTIPLY);
2693
2694     case '%':
2695         if (PL_expect == XOPERATOR) {
2696             ++s;
2697             Mop(OP_MODULO);
2698         }
2699         PL_tokenbuf[0] = '%';
2700         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2701         if (!PL_tokenbuf[1]) {
2702             if (s == PL_bufend)
2703                 yyerror("Final % should be \\% or %name");
2704             PREREF('%');
2705         }
2706         PL_pending_ident = '%';
2707         TERM('%');
2708
2709     case '^':
2710         s++;
2711         BOop(OP_BIT_XOR);
2712     case '[':
2713         PL_lex_brackets++;
2714         /* FALL THROUGH */
2715     case '~':
2716     case ',':
2717         tmp = *s++;
2718         OPERATOR(tmp);
2719     case ':':
2720         if (s[1] == ':') {
2721             len = 0;
2722             goto just_a_word;
2723         }
2724         s++;
2725         switch (PL_expect) {
2726             OP *attrs;
2727         case XOPERATOR:
2728             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2729                 break;
2730             PL_bufptr = s;      /* update in case we back off */
2731             goto grabattrs;
2732         case XATTRBLOCK:
2733             PL_expect = XBLOCK;
2734             goto grabattrs;
2735         case XATTRTERM:
2736             PL_expect = XTERMBLOCK;
2737          grabattrs:
2738             s = skipspace(s);
2739             attrs = Nullop;
2740             while (isIDFIRST_lazy(s)) {
2741                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2742                 if (*d == '(') {
2743                     d = scan_str(d,TRUE,TRUE);
2744                     if (!d) {
2745                         if (PL_lex_stuff) {
2746                             SvREFCNT_dec(PL_lex_stuff);
2747                             PL_lex_stuff = Nullsv;
2748                         }
2749                         /* MUST advance bufptr here to avoid bogus
2750                            "at end of line" context messages from yyerror().
2751                          */
2752                         PL_bufptr = s + len;
2753                         yyerror("Unterminated attribute parameter in attribute list");
2754                         if (attrs)
2755                             op_free(attrs);
2756                         return 0;       /* EOF indicator */
2757                     }
2758                 }
2759                 if (PL_lex_stuff) {
2760                     SV *sv = newSVpvn(s, len);
2761                     sv_catsv(sv, PL_lex_stuff);
2762                     attrs = append_elem(OP_LIST, attrs,
2763                                         newSVOP(OP_CONST, 0, sv));
2764                     SvREFCNT_dec(PL_lex_stuff);
2765                     PL_lex_stuff = Nullsv;
2766                 }
2767                 else {
2768                     attrs = append_elem(OP_LIST, attrs,
2769                                         newSVOP(OP_CONST, 0,
2770                                                 newSVpvn(s, len)));
2771                 }
2772                 s = skipspace(d);
2773                 while (*s == ',')
2774                     s = skipspace(s+1);
2775             }
2776             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}' for vi */
2777             if (*s != ';' && *s != tmp) {
2778                 char q = ((*s == '\'') ? '"' : '\'');
2779                 /* If here for an expression, and parsed no attrs, back off. */
2780                 if (tmp == '=' && !attrs) {
2781                     s = PL_bufptr;
2782                     break;
2783                 }
2784                 /* MUST advance bufptr here to avoid bogus "at end of line"
2785                    context messages from yyerror().
2786                  */
2787                 PL_bufptr = s;
2788                 if (!*s)
2789                     yyerror("Unterminated attribute list");
2790                 else
2791                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2792                                       q, *s, q));
2793                 if (attrs)
2794                     op_free(attrs);
2795                 OPERATOR(':');
2796             }
2797             if (attrs) {
2798                 PL_nextval[PL_nexttoke].opval = attrs;
2799                 force_next(THING);
2800             }
2801             TOKEN(COLONATTR);
2802         }
2803         OPERATOR(':');
2804     case '(':
2805         s++;
2806         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2807             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
2808         else
2809             PL_expect = XTERM;
2810         TOKEN('(');
2811     case ';':
2812         if (PL_curcop->cop_line < PL_copline)
2813             PL_copline = PL_curcop->cop_line;
2814         tmp = *s++;
2815         OPERATOR(tmp);
2816     case ')':
2817         tmp = *s++;
2818         s = skipspace(s);
2819         if (*s == '{')
2820             PREBLOCK(tmp);
2821         TERM(tmp);
2822     case ']':
2823         s++;
2824         if (PL_lex_brackets <= 0)
2825             yyerror("Unmatched right square bracket");
2826         else
2827             --PL_lex_brackets;
2828         if (PL_lex_state == LEX_INTERPNORMAL) {
2829             if (PL_lex_brackets == 0) {
2830                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2831                     PL_lex_state = LEX_INTERPEND;
2832             }
2833         }
2834         TERM(']');
2835     case '{':
2836       leftbracket:
2837         s++;
2838         if (PL_lex_brackets > 100) {
2839             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2840             if (newlb != PL_lex_brackstack) {
2841                 SAVEFREEPV(newlb);
2842                 PL_lex_brackstack = newlb;
2843             }
2844         }
2845         switch (PL_expect) {
2846         case XTERM:
2847             if (PL_lex_formbrack) {
2848                 s--;
2849                 PRETERMBLOCK(DO);
2850             }
2851             if (PL_oldoldbufptr == PL_last_lop)
2852                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2853             else
2854                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2855             OPERATOR(HASHBRACK);
2856         case XOPERATOR:
2857             while (s < PL_bufend && SPACE_OR_TAB(*s))
2858                 s++;
2859             d = s;
2860             PL_tokenbuf[0] = '\0';
2861             if (d < PL_bufend && *d == '-') {
2862                 PL_tokenbuf[0] = '-';
2863                 d++;
2864                 while (d < PL_bufend && SPACE_OR_TAB(*d))
2865                     d++;
2866             }
2867             if (d < PL_bufend && isIDFIRST_lazy(d)) {
2868                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2869                               FALSE, &len);
2870                 while (d < PL_bufend && SPACE_OR_TAB(*d))
2871                     d++;
2872                 if (*d == '}') {
2873                     char minus = (PL_tokenbuf[0] == '-');
2874                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2875                     if (minus)
2876                         force_next('-');
2877                 }
2878             }
2879             /* FALL THROUGH */
2880         case XATTRBLOCK:
2881         case XBLOCK:
2882             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2883             PL_expect = XSTATE;
2884             break;
2885         case XATTRTERM:
2886         case XTERMBLOCK:
2887             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2888             PL_expect = XSTATE;
2889             break;
2890         default: {
2891                 char *t;
2892                 if (PL_oldoldbufptr == PL_last_lop)
2893                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2894                 else
2895                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2896                 s = skipspace(s);
2897                 if (*s == '}')
2898                     OPERATOR(HASHBRACK);
2899                 /* This hack serves to disambiguate a pair of curlies
2900                  * as being a block or an anon hash.  Normally, expectation
2901                  * determines that, but in cases where we're not in a
2902                  * position to expect anything in particular (like inside
2903                  * eval"") we have to resolve the ambiguity.  This code
2904                  * covers the case where the first term in the curlies is a
2905                  * quoted string.  Most other cases need to be explicitly
2906                  * disambiguated by prepending a `+' before the opening
2907                  * curly in order to force resolution as an anon hash.
2908                  *
2909                  * XXX should probably propagate the outer expectation
2910                  * into eval"" to rely less on this hack, but that could
2911                  * potentially break current behavior of eval"".
2912                  * GSAR 97-07-21
2913                  */
2914                 t = s;
2915                 if (*s == '\'' || *s == '"' || *s == '`') {
2916                     /* common case: get past first string, handling escapes */
2917                     for (t++; t < PL_bufend && *t != *s;)
2918                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
2919                             t++;
2920                     t++;
2921                 }
2922                 else if (*s == 'q') {
2923                     if (++t < PL_bufend
2924                         && (!isALNUM(*t)
2925                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2926                                 && !isALNUM(*t)))) {
2927                         char *tmps;
2928                         char open, close, term;
2929                         I32 brackets = 1;
2930
2931                         while (t < PL_bufend && isSPACE(*t))
2932                             t++;
2933                         term = *t;
2934                         open = term;
2935                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2936                             term = tmps[5];
2937                         close = term;
2938                         if (open == close)
2939                             for (t++; t < PL_bufend; t++) {
2940                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2941                                     t++;
2942                                 else if (*t == open)
2943                                     break;
2944                             }
2945                         else
2946                             for (t++; t < PL_bufend; t++) {
2947                                 if (*t == '\\' && t+1 < PL_bufend)
2948                                     t++;
2949                                 else if (*t == close && --brackets <= 0)
2950                                     break;
2951                                 else if (*t == open)
2952                                     brackets++;
2953                             }
2954                     }
2955                     t++;
2956                 }
2957                 else if (isIDFIRST_lazy(s)) {
2958                     for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2959                 }
2960                 while (t < PL_bufend && isSPACE(*t))
2961                     t++;
2962                 /* if comma follows first term, call it an anon hash */
2963                 /* XXX it could be a comma expression with loop modifiers */
2964                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2965                                    || (*t == '=' && t[1] == '>')))
2966                     OPERATOR(HASHBRACK);
2967                 if (PL_expect == XREF)
2968                     PL_expect = XTERM;
2969                 else {
2970                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2971                     PL_expect = XSTATE;
2972                 }
2973             }
2974             break;
2975         }
2976         yylval.ival = PL_curcop->cop_line;
2977         if (isSPACE(*s) || *s == '#')
2978             PL_copline = NOLINE;   /* invalidate current command line number */
2979         TOKEN('{');
2980     case '}':
2981       rightbracket:
2982         s++;
2983         if (PL_lex_brackets <= 0)
2984             yyerror("Unmatched right curly bracket");
2985         else
2986             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2987         if (PL_lex_brackets < PL_lex_formbrack)
2988             PL_lex_formbrack = 0;
2989         if (PL_lex_state == LEX_INTERPNORMAL) {
2990             if (PL_lex_brackets == 0) {
2991                 if (PL_lex_fakebrack) {
2992                     PL_lex_state = LEX_INTERPEND;
2993                     PL_bufptr = s;
2994                     return yylex();     /* ignore fake brackets */
2995                 }
2996                 if (*s == '-' && s[1] == '>')
2997                     PL_lex_state = LEX_INTERPENDMAYBE;
2998                 else if (*s != '[' && *s != '{')
2999                     PL_lex_state = LEX_INTERPEND;
3000             }
3001         }
3002         if (PL_lex_brackets < PL_lex_fakebrack) {
3003             PL_bufptr = s;
3004             PL_lex_fakebrack = 0;
3005             return yylex();             /* ignore fake brackets */
3006         }
3007         force_next('}');
3008         TOKEN(';');
3009     case '&':
3010         s++;
3011         tmp = *s++;
3012         if (tmp == '&')
3013             AOPERATOR(ANDAND);
3014         s--;
3015         if (PL_expect == XOPERATOR) {
3016             if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
3017                 PL_curcop->cop_line--;
3018                 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3019                 PL_curcop->cop_line++;
3020             }
3021             BAop(OP_BIT_AND);
3022         }
3023
3024         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3025         if (*PL_tokenbuf) {
3026             PL_expect = XOPERATOR;
3027             force_ident(PL_tokenbuf, '&');
3028         }
3029         else
3030             PREREF('&');
3031         yylval.ival = (OPpENTERSUB_AMPER<<8);
3032         TERM('&');
3033
3034     case '|':
3035         s++;
3036         tmp = *s++;
3037         if (tmp == '|')
3038             AOPERATOR(OROR);
3039         s--;
3040         BOop(OP_BIT_OR);
3041     case '=':
3042         s++;
3043         tmp = *s++;
3044         if (tmp == '=')
3045             Eop(OP_EQ);
3046         if (tmp == '>')
3047             OPERATOR(',');
3048         if (tmp == '~')
3049             PMop(OP_MATCH);
3050         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3051             Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3052         s--;
3053         if (PL_expect == XSTATE && isALPHA(tmp) &&
3054                 (s == PL_linestart+1 || s[-2] == '\n') )
3055         {
3056             if (PL_in_eval && !PL_rsfp) {
3057                 d = PL_bufend;
3058                 while (s < d) {
3059                     if (*s++ == '\n') {
3060                         incline(s);
3061                         if (strnEQ(s,"=cut",4)) {
3062                             s = strchr(s,'\n');
3063                             if (s)
3064                                 s++;
3065                             else
3066                                 s = d;
3067                             incline(s);
3068                             goto retry;
3069                         }
3070                     }
3071                 }
3072                 goto retry;
3073             }
3074             s = PL_bufend;
3075             PL_doextract = TRUE;
3076             goto retry;
3077         }
3078         if (PL_lex_brackets < PL_lex_formbrack) {
3079             char *t;
3080 #ifdef PERL_STRICT_CR
3081             for (t = s; SPACE_OR_TAB(*t); t++) ;
3082 #else
3083             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3084 #endif
3085             if (*t == '\n' || *t == '#') {
3086                 s--;
3087                 PL_expect = XBLOCK;
3088                 goto leftbracket;
3089             }
3090         }
3091         yylval.ival = 0;
3092         OPERATOR(ASSIGNOP);
3093     case '!':
3094         s++;
3095         tmp = *s++;
3096         if (tmp == '=')
3097             Eop(OP_NE);
3098         if (tmp == '~')
3099             PMop(OP_NOT);
3100         s--;
3101         OPERATOR('!');
3102     case '<':
3103         if (PL_expect != XOPERATOR) {
3104             if (s[1] != '<' && !strchr(s,'>'))
3105                 check_uni();
3106             if (s[1] == '<')
3107                 s = scan_heredoc(s);
3108             else
3109                 s = scan_inputsymbol(s);
3110             TERM(sublex_start());
3111         }
3112         s++;
3113         tmp = *s++;
3114         if (tmp == '<')
3115             SHop(OP_LEFT_SHIFT);
3116         if (tmp == '=') {
3117             tmp = *s++;
3118             if (tmp == '>')
3119                 Eop(OP_NCMP);
3120             s--;
3121             Rop(OP_LE);
3122         }
3123         s--;
3124         Rop(OP_LT);
3125     case '>':
3126         s++;
3127         tmp = *s++;
3128         if (tmp == '>')
3129             SHop(OP_RIGHT_SHIFT);
3130         if (tmp == '=')
3131             Rop(OP_GE);
3132         s--;
3133         Rop(OP_GT);
3134
3135     case '$':
3136         CLINE;
3137
3138         if (PL_expect == XOPERATOR) {
3139             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3140                 PL_expect = XTERM;
3141                 depcom();
3142                 return ','; /* grandfather non-comma-format format */
3143             }
3144         }
3145
3146         if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
3147             PL_tokenbuf[0] = '@';
3148             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3149                            sizeof PL_tokenbuf - 1, FALSE);
3150             if (PL_expect == XOPERATOR)
3151                 no_op("Array length", s);
3152             if (!PL_tokenbuf[1])
3153                 PREREF(DOLSHARP);
3154             PL_expect = XOPERATOR;
3155             PL_pending_ident = '#';
3156             TOKEN(DOLSHARP);
3157         }
3158
3159         PL_tokenbuf[0] = '$';
3160         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3161                        sizeof PL_tokenbuf - 1, FALSE);
3162         if (PL_expect == XOPERATOR)
3163             no_op("Scalar", s);
3164         if (!PL_tokenbuf[1]) {
3165             if (s == PL_bufend)
3166                 yyerror("Final $ should be \\$ or $name");
3167             PREREF('$');
3168         }
3169
3170         /* This kludge not intended to be bulletproof. */
3171         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3172             yylval.opval = newSVOP(OP_CONST, 0,
3173                                    newSViv((IV)PL_compiling.cop_arybase));
3174             yylval.opval->op_private = OPpCONST_ARYBASE;
3175             TERM(THING);
3176         }
3177
3178         d = s;
3179         tmp = (I32)*s;
3180         if (PL_lex_state == LEX_NORMAL)
3181             s = skipspace(s);
3182
3183         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3184             char *t;
3185             if (*s == '[') {
3186                 PL_tokenbuf[0] = '@';
3187                 if (ckWARN(WARN_SYNTAX)) {
3188                     for(t = s + 1;
3189                         isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
3190                         t++) ;
3191                     if (*t++ == ',') {
3192                         PL_bufptr = skipspace(PL_bufptr);
3193                         while (t < PL_bufend && *t != ']')
3194                             t++;
3195                         Perl_warner(aTHX_ WARN_SYNTAX,
3196                                 "Multidimensional syntax %.*s not supported",
3197                                 (t - PL_bufptr) + 1, PL_bufptr);
3198                     }
3199                 }
3200             }
3201             else if (*s == '{') {
3202                 PL_tokenbuf[0] = '%';
3203                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3204                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3205                 {
3206                     char tmpbuf[sizeof PL_tokenbuf];
3207                     STRLEN len;
3208                     for (t++; isSPACE(*t); t++) ;
3209                     if (isIDFIRST_lazy(t)) {
3210                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3211                         for (; isSPACE(*t); t++) ;
3212                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3213                             Perl_warner(aTHX_ WARN_SYNTAX,
3214                                 "You need to quote \"%s\"", tmpbuf);
3215                     }
3216                 }
3217             }
3218         }
3219
3220         PL_expect = XOPERATOR;
3221         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3222             bool islop = (PL_last_lop == PL_oldoldbufptr);
3223             if (!islop || PL_last_lop_op == OP_GREPSTART)
3224                 PL_expect = XOPERATOR;
3225             else if (strchr("$@\"'`q", *s))
3226                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3227             else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
3228                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3229             else if (isIDFIRST_lazy(s)) {
3230                 char tmpbuf[sizeof PL_tokenbuf];
3231                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3232                 if (tmp = keyword(tmpbuf, len)) {
3233                     /* binary operators exclude handle interpretations */
3234                     switch (tmp) {
3235                     case -KEY_x:
3236                     case -KEY_eq:
3237                     case -KEY_ne:
3238                     case -KEY_gt:
3239                     case -KEY_lt:
3240                     case -KEY_ge:
3241                     case -KEY_le:
3242                     case -KEY_cmp:
3243                         break;
3244                     default:
3245                         PL_expect = XTERM;      /* e.g. print $fh length() */
3246                         break;
3247                     }
3248                 }
3249                 else {
3250                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3251                     if (gv && GvCVu(gv))
3252                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3253                 }
3254             }
3255             else if (isDIGIT(*s))
3256                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3257             else if (*s == '.' && isDIGIT(s[1]))
3258                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3259             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3260                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3261             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3262                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3263         }
3264         PL_pending_ident = '$';
3265         TOKEN('$');
3266
3267     case '@':
3268         if (PL_expect == XOPERATOR)
3269             no_op("Array", s);
3270         PL_tokenbuf[0] = '@';
3271         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3272         if (!PL_tokenbuf[1]) {
3273             if (s == PL_bufend)
3274                 yyerror("Final @ should be \\@ or @name");
3275             PREREF('@');
3276         }
3277         if (PL_lex_state == LEX_NORMAL)
3278             s = skipspace(s);
3279         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3280             if (*s == '{')
3281                 PL_tokenbuf[0] = '%';
3282
3283             /* Warn about @ where they meant $. */
3284             if (ckWARN(WARN_SYNTAX)) {
3285                 if (*s == '[' || *s == '{') {
3286                     char *t = s + 1;
3287                     while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
3288                         t++;
3289                     if (*t == '}' || *t == ']') {
3290                         t++;
3291                         PL_bufptr = skipspace(PL_bufptr);
3292                         Perl_warner(aTHX_ WARN_SYNTAX,
3293                             "Scalar value %.*s better written as $%.*s",
3294                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3295                     }
3296                 }
3297             }
3298         }
3299         PL_pending_ident = '@';
3300         TERM('@');
3301
3302     case '/':                   /* may either be division or pattern */
3303     case '?':                   /* may either be conditional or pattern */
3304         if (PL_expect != XOPERATOR) {
3305             /* Disable warning on "study /blah/" */
3306             if (PL_oldoldbufptr == PL_last_uni
3307                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3308                     || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
3309                 check_uni();
3310             s = scan_pat(s,OP_MATCH);
3311             TERM(sublex_start());
3312         }
3313         tmp = *s++;
3314         if (tmp == '/')
3315             Mop(OP_DIVIDE);
3316         OPERATOR(tmp);
3317
3318     case '.':
3319         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3320 #ifdef PERL_STRICT_CR
3321             && s[1] == '\n'
3322 #else
3323             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3324 #endif
3325             && (s == PL_linestart || s[-1] == '\n') )
3326         {
3327             PL_lex_formbrack = 0;
3328             PL_expect = XSTATE;
3329             goto rightbracket;
3330         }
3331         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3332             tmp = *s++;
3333             if (*s == tmp) {
3334                 s++;
3335                 if (*s == tmp) {
3336                     s++;
3337                     yylval.ival = OPf_SPECIAL;
3338                 }
3339                 else
3340                     yylval.ival = 0;
3341                 OPERATOR(DOTDOT);
3342             }
3343             if (PL_expect != XOPERATOR)
3344                 check_uni();
3345             Aop(OP_CONCAT);
3346         }
3347         /* FALL THROUGH */
3348     case '0': case '1': case '2': case '3': case '4':
3349     case '5': case '6': case '7': case '8': case '9':
3350         s = scan_num(s);
3351         if (PL_expect == XOPERATOR)
3352             no_op("Number",s);
3353         TERM(THING);
3354
3355     case '\'':
3356         s = scan_str(s,FALSE,FALSE);
3357         if (PL_expect == XOPERATOR) {
3358             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3359                 PL_expect = XTERM;
3360                 depcom();
3361                 return ',';     /* grandfather non-comma-format format */
3362             }
3363             else
3364                 no_op("String",s);
3365         }
3366         if (!s)
3367             missingterm((char*)0);
3368         yylval.ival = OP_CONST;
3369         TERM(sublex_start());
3370
3371     case '"':
3372         s = scan_str(s,FALSE,FALSE);
3373         if (PL_expect == XOPERATOR) {
3374             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3375                 PL_expect = XTERM;
3376                 depcom();
3377                 return ',';     /* grandfather non-comma-format format */
3378             }
3379             else
3380                 no_op("String",s);
3381         }
3382         if (!s)
3383             missingterm((char*)0);
3384         yylval.ival = OP_CONST;
3385         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3386             if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3387                 yylval.ival = OP_STRINGIFY;
3388                 break;
3389             }
3390         }
3391         TERM(sublex_start());
3392
3393     case '`':
3394         s = scan_str(s,FALSE,FALSE);
3395         if (PL_expect == XOPERATOR)
3396             no_op("Backticks",s);
3397         if (!s)
3398             missingterm((char*)0);
3399         yylval.ival = OP_BACKTICK;
3400         set_csh();
3401         TERM(sublex_start());
3402
3403     case '\\':
3404         s++;
3405         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3406             Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3407                         *s, *s);
3408         if (PL_expect == XOPERATOR)
3409             no_op("Backslash",s);
3410         OPERATOR(REFGEN);
3411
3412     case 'x':
3413         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3414             s++;
3415             Mop(OP_REPEAT);
3416         }
3417         goto keylookup;
3418
3419     case '_':
3420     case 'a': case 'A':
3421     case 'b': case 'B':
3422     case 'c': case 'C':
3423     case 'd': case 'D':
3424     case 'e': case 'E':
3425     case 'f': case 'F':
3426     case 'g': case 'G':
3427     case 'h': case 'H':
3428     case 'i': case 'I':
3429     case 'j': case 'J':
3430     case 'k': case 'K':
3431     case 'l': case 'L':
3432     case 'm': case 'M':
3433     case 'n': case 'N':
3434     case 'o': case 'O':
3435     case 'p': case 'P':
3436     case 'q': case 'Q':
3437     case 'r': case 'R':
3438     case 's': case 'S':
3439     case 't': case 'T':
3440     case 'u': case 'U':
3441     case 'v': case 'V':
3442     case 'w': case 'W':
3443               case 'X':
3444     case 'y': case 'Y':
3445     case 'z': case 'Z':
3446
3447       keylookup: {
3448         STRLEN n_a;
3449         gv = Nullgv;
3450         gvp = 0;
3451
3452         PL_bufptr = s;
3453         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3454
3455         /* Some keywords can be followed by any delimiter, including ':' */
3456         tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3457                len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3458                             (PL_tokenbuf[0] == 'q' &&
3459                              strchr("qwxr", PL_tokenbuf[1]))));
3460
3461         /* x::* is just a word, unless x is "CORE" */
3462         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3463             goto just_a_word;
3464
3465         d = s;
3466         while (d < PL_bufend && isSPACE(*d))
3467                 d++;    /* no comments skipped here, or s### is misparsed */
3468
3469         /* Is this a label? */
3470         if (!tmp && PL_expect == XSTATE
3471               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3472             s = d + 1;
3473             yylval.pval = savepv(PL_tokenbuf);
3474             CLINE;
3475             TOKEN(LABEL);
3476         }
3477
3478         /* Check for keywords */
3479         tmp = keyword(PL_tokenbuf, len);
3480
3481         /* Is this a word before a => operator? */
3482         if (strnEQ(d,"=>",2)) {
3483             CLINE;
3484             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3485             yylval.opval->op_private = OPpCONST_BARE;
3486             TERM(WORD);
3487         }
3488
3489         if (tmp < 0) {                  /* second-class keyword? */
3490             GV *ogv = Nullgv;   /* override (winner) */
3491             GV *hgv = Nullgv;   /* hidden (loser) */
3492             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3493                 CV *cv;
3494                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3495                     (cv = GvCVu(gv)))
3496                 {
3497                     if (GvIMPORTED_CV(gv))
3498                         ogv = gv;
3499                     else if (! CvMETHOD(cv))
3500                         hgv = gv;
3501                 }
3502                 if (!ogv &&
3503                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3504                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3505                     GvCVu(gv) && GvIMPORTED_CV(gv))
3506                 {
3507                     ogv = gv;
3508                 }
3509             }
3510             if (ogv) {
3511                 tmp = 0;                /* overridden by import or by GLOBAL */
3512             }
3513             else if (gv && !gvp
3514                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3515                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3516             {
3517                 tmp = 0;                /* any sub overrides "weak" keyword */
3518             }
3519             else {                      /* no override */
3520                 tmp = -tmp;
3521                 gv = Nullgv;
3522                 gvp = 0;
3523                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3524                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3525                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3526                         "Ambiguous call resolved as CORE::%s(), %s",
3527                          GvENAME(hgv), "qualify as such or use &");
3528             }
3529         }
3530
3531       reserved_word:
3532         switch (tmp) {
3533
3534         default:                        /* not a keyword */
3535           just_a_word: {
3536                 SV *sv;
3537                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3538
3539                 /* Get the rest if it looks like a package qualifier */
3540
3541                 if (*s == '\'' || *s == ':' && s[1] == ':') {
3542                     STRLEN morelen;
3543                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3544                                   TRUE, &morelen);
3545                     if (!morelen)
3546                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3547                                 *s == '\'' ? "'" : "::");
3548                     len += morelen;
3549                 }
3550
3551                 if (PL_expect == XOPERATOR) {
3552                     if (PL_bufptr == PL_linestart) {
3553                         PL_curcop->cop_line--;
3554                         Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3555                         PL_curcop->cop_line++;
3556                     }
3557                     else
3558                         no_op("Bareword",s);
3559                 }
3560
3561                 /* Look for a subroutine with this name in current package,
3562                    unless name is "Foo::", in which case Foo is a bearword
3563                    (and a package name). */
3564
3565                 if (len > 2 &&
3566                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3567                 {
3568                     if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3569                         Perl_warner(aTHX_ WARN_UNSAFE,
3570                             "Bareword \"%s\" refers to nonexistent package",
3571                              PL_tokenbuf);
3572                     len -= 2;
3573                     PL_tokenbuf[len] = '\0';
3574                     gv = Nullgv;
3575                     gvp = 0;
3576                 }
3577                 else {
3578                     len = 0;
3579                     if (!gv)
3580                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3581                 }
3582
3583                 /* if we saw a global override before, get the right name */
3584
3585                 if (gvp) {
3586                     sv = newSVpvn("CORE::GLOBAL::",14);
3587                     sv_catpv(sv,PL_tokenbuf);
3588                 }
3589                 else
3590                     sv = newSVpv(PL_tokenbuf,0);
3591
3592                 /* Presume this is going to be a bareword of some sort. */
3593
3594                 CLINE;
3595                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3596                 yylval.opval->op_private = OPpCONST_BARE;
3597
3598                 /* And if "Foo::", then that's what it certainly is. */
3599
3600                 if (len)
3601                     goto safe_bareword;
3602
3603                 /* See if it's the indirect object for a list operator. */
3604
3605                 if (PL_oldoldbufptr &&
3606                     PL_oldoldbufptr < PL_bufptr &&
3607                     (PL_oldoldbufptr == PL_last_lop
3608                      || PL_oldoldbufptr == PL_last_uni) &&
3609                     /* NO SKIPSPACE BEFORE HERE! */
3610                     (PL_expect == XREF ||
3611                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3612                 {
3613                     bool immediate_paren = *s == '(';
3614
3615                     /* (Now we can afford to cross potential line boundary.) */
3616                     s = skipspace(s);
3617
3618                     /* Two barewords in a row may indicate method call. */
3619
3620                     if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3621                         return tmp;
3622
3623                     /* If not a declared subroutine, it's an indirect object. */
3624                     /* (But it's an indir obj regardless for sort.) */
3625
3626                     if ((PL_last_lop_op == OP_SORT ||
3627                          (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3628                         (PL_last_lop_op != OP_MAPSTART &&
3629                          PL_last_lop_op != OP_GREPSTART))
3630                     {
3631                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3632                         goto bareword;
3633                     }
3634                 }
3635
3636                 /* If followed by a paren, it's certainly a subroutine. */
3637
3638                 PL_expect = XOPERATOR;
3639                 s = skipspace(s);
3640                 if (*s == '(') {
3641                     CLINE;
3642                     if (gv && GvCVu(gv)) {
3643                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3644                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3645                             s = d + 1;
3646                             goto its_constant;
3647                         }
3648                     }
3649                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3650                     PL_expect = XOPERATOR;
3651                     force_next(WORD);
3652                     yylval.ival = 0;
3653                     TOKEN('&');
3654                 }
3655
3656                 /* If followed by var or block, call it a method (unless sub) */
3657
3658                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3659                     PL_last_lop = PL_oldbufptr;
3660                     PL_last_lop_op = OP_METHOD;
3661                     PREBLOCK(METHOD);
3662                 }
3663
3664                 /* If followed by a bareword, see if it looks like indir obj. */
3665
3666                 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3667                     return tmp;
3668
3669                 /* Not a method, so call it a subroutine (if defined) */
3670
3671                 if (gv && GvCVu(gv)) {
3672                     CV* cv;
3673                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3674                         Perl_warner(aTHX_ WARN_AMBIGUOUS,
3675                                 "Ambiguous use of -%s resolved as -&%s()",
3676                                 PL_tokenbuf, PL_tokenbuf);
3677                     /* Check for a constant sub */
3678                     cv = GvCV(gv);
3679                     if ((sv = cv_const_sv(cv))) {
3680                   its_constant:
3681                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3682                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3683                         yylval.opval->op_private = 0;
3684                         TOKEN(WORD);
3685                     }
3686
3687                     /* Resolve to GV now. */
3688                     op_free(yylval.opval);
3689                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3690                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3691                     PL_last_lop = PL_oldbufptr;
3692                     PL_last_lop_op = OP_ENTERSUB;
3693                     /* Is there a prototype? */
3694                     if (SvPOK(cv)) {
3695                         STRLEN len;
3696                         char *proto = SvPV((SV*)cv, len);
3697                         if (!len)
3698                             TERM(FUNC0SUB);
3699                         if (strEQ(proto, "$"))
3700                             OPERATOR(UNIOPSUB);
3701                         if (*proto == '&' && *s == '{') {
3702                             sv_setpv(PL_subname,"__ANON__");
3703                             PREBLOCK(LSTOPSUB);
3704                         }
3705                     }
3706                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3707                     PL_expect = XTERM;
3708                     force_next(WORD);
3709                     TOKEN(NOAMP);
3710                 }
3711
3712                 /* Call it a bare word */
3713
3714                 if (PL_hints & HINT_STRICT_SUBS)
3715                     yylval.opval->op_private |= OPpCONST_STRICT;
3716                 else {
3717                 bareword:
3718                     if (ckWARN(WARN_RESERVED)) {
3719                         if (lastchar != '-') {
3720                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3721                             if (!*d)
3722                                 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3723                                        PL_tokenbuf);
3724                         }
3725                     }
3726                 }
3727
3728             safe_bareword:
3729                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3730                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3731                         "Operator or semicolon missing before %c%s",
3732                         lastchar, PL_tokenbuf);
3733                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3734                         "Ambiguous use of %c resolved as operator %c",
3735                         lastchar, lastchar);
3736                 }
3737                 TOKEN(WORD);
3738             }
3739
3740         case KEY___FILE__:
3741             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3742                                         newSVsv(GvSV(PL_curcop->cop_filegv)));
3743             TERM(THING);
3744
3745         case KEY___LINE__:
3746             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3747                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)PL_curcop->cop_line));
3748             TERM(THING);
3749
3750         case KEY___PACKAGE__:
3751             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3752                                         (PL_curstash
3753                                          ? newSVsv(PL_curstname)
3754                                          : &PL_sv_undef));
3755             TERM(THING);
3756
3757         case KEY___DATA__:
3758         case KEY___END__: {
3759             GV *gv;
3760
3761             /*SUPPRESS 560*/
3762             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3763                 char *pname = "main";
3764                 if (PL_tokenbuf[2] == 'D')
3765                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3766                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3767                 GvMULTI_on(gv);
3768                 if (!GvIO(gv))
3769                     GvIOp(gv) = newIO();
3770                 IoIFP(GvIOp(gv)) = PL_rsfp;
3771 #if defined(HAS_FCNTL) && defined(F_SETFD)
3772                 {
3773                     int fd = PerlIO_fileno(PL_rsfp);
3774                     fcntl(fd,F_SETFD,fd >= 3);
3775                 }
3776 #endif
3777                 /* Mark this internal pseudo-handle as clean */
3778                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3779                 if (PL_preprocess)
3780                     IoTYPE(GvIOp(gv)) = '|';
3781                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3782                     IoTYPE(GvIOp(gv)) = '-';
3783                 else
3784                     IoTYPE(GvIOp(gv)) = '<';
3785                 PL_rsfp = Nullfp;
3786             }
3787             goto fake_eof;
3788         }
3789
3790         case KEY_AUTOLOAD:
3791         case KEY_DESTROY:
3792         case KEY_BEGIN:
3793         case KEY_END:
3794         case KEY_INIT:
3795             if (PL_expect == XSTATE) {
3796                 s = PL_bufptr;
3797                 goto really_sub;
3798             }
3799             goto just_a_word;
3800
3801         case KEY_CORE:
3802             if (*s == ':' && s[1] == ':') {
3803                 s += 2;
3804                 d = s;
3805                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3806                 tmp = keyword(PL_tokenbuf, len);
3807                 if (tmp < 0)
3808                     tmp = -tmp;
3809                 goto reserved_word;
3810             }
3811             goto just_a_word;
3812
3813         case KEY_abs:
3814             UNI(OP_ABS);
3815
3816         case KEY_alarm:
3817             UNI(OP_ALARM);
3818
3819         case KEY_accept:
3820             LOP(OP_ACCEPT,XTERM);
3821
3822         case KEY_and:
3823             OPERATOR(ANDOP);
3824
3825         case KEY_atan2:
3826             LOP(OP_ATAN2,XTERM);
3827
3828         case KEY_bind:
3829             LOP(OP_BIND,XTERM);
3830
3831         case KEY_binmode:
3832             UNI(OP_BINMODE);
3833
3834         case KEY_bless:
3835             LOP(OP_BLESS,XTERM);
3836
3837         case KEY_chop:
3838             UNI(OP_CHOP);
3839
3840         case KEY_continue:
3841             PREBLOCK(CONTINUE);
3842
3843         case KEY_chdir:
3844             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3845             UNI(OP_CHDIR);
3846
3847         case KEY_close:
3848             UNI(OP_CLOSE);
3849
3850         case KEY_closedir:
3851             UNI(OP_CLOSEDIR);
3852
3853         case KEY_cmp:
3854             Eop(OP_SCMP);
3855
3856         case KEY_caller:
3857             UNI(OP_CALLER);
3858
3859         case KEY_crypt:
3860 #ifdef FCRYPT
3861             if (!PL_cryptseen) {
3862                 PL_cryptseen = TRUE;
3863                 init_des();
3864             }
3865 #endif
3866             LOP(OP_CRYPT,XTERM);
3867
3868         case KEY_chmod:
3869             if (ckWARN(WARN_OCTAL)) {
3870                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3871                 if (*d != '0' && isDIGIT(*d))
3872                     Perl_warner(aTHX_ WARN_OCTAL,
3873                                 "chmod: mode argument is missing initial 0");
3874             }
3875             LOP(OP_CHMOD,XTERM);
3876
3877         case KEY_chown:
3878             LOP(OP_CHOWN,XTERM);
3879
3880         case KEY_connect:
3881             LOP(OP_CONNECT,XTERM);
3882
3883         case KEY_chr:
3884             UNI(OP_CHR);
3885
3886         case KEY_cos:
3887             UNI(OP_COS);
3888
3889         case KEY_chroot:
3890             UNI(OP_CHROOT);
3891
3892         case KEY_do:
3893             s = skipspace(s);
3894             if (*s == '{')
3895                 PRETERMBLOCK(DO);
3896             if (*s != '\'')
3897                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3898             OPERATOR(DO);
3899
3900         case KEY_die:
3901             PL_hints |= HINT_BLOCK_SCOPE;
3902             LOP(OP_DIE,XTERM);
3903
3904         case KEY_defined:
3905             UNI(OP_DEFINED);
3906
3907         case KEY_delete:
3908             UNI(OP_DELETE);
3909
3910         case KEY_dbmopen:
3911             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3912             LOP(OP_DBMOPEN,XTERM);
3913
3914         case KEY_dbmclose:
3915             UNI(OP_DBMCLOSE);
3916
3917         case KEY_dump:
3918             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3919             LOOPX(OP_DUMP);
3920
3921         case KEY_else:
3922             PREBLOCK(ELSE);
3923
3924         case KEY_elsif:
3925             yylval.ival = PL_curcop->cop_line;
3926             OPERATOR(ELSIF);
3927
3928         case KEY_eq:
3929             Eop(OP_SEQ);
3930
3931         case KEY_exists:
3932             UNI(OP_EXISTS);
3933
3934         case KEY_exit:
3935             UNI(OP_EXIT);
3936
3937         case KEY_eval:
3938             s = skipspace(s);
3939             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3940             UNIBRACK(OP_ENTEREVAL);
3941
3942         case KEY_eof:
3943             UNI(OP_EOF);
3944
3945         case KEY_exp:
3946             UNI(OP_EXP);
3947
3948         case KEY_each:
3949             UNI(OP_EACH);
3950
3951         case KEY_exec:
3952             set_csh();
3953             LOP(OP_EXEC,XREF);
3954
3955         case KEY_endhostent:
3956             FUN0(OP_EHOSTENT);
3957
3958         case KEY_endnetent:
3959             FUN0(OP_ENETENT);
3960
3961         case KEY_endservent:
3962             FUN0(OP_ESERVENT);
3963
3964         case KEY_endprotoent:
3965             FUN0(OP_EPROTOENT);
3966
3967         case KEY_endpwent:
3968             FUN0(OP_EPWENT);
3969
3970         case KEY_endgrent:
3971             FUN0(OP_EGRENT);
3972
3973         case KEY_for:
3974         case KEY_foreach:
3975             yylval.ival = PL_curcop->cop_line;
3976             s = skipspace(s);
3977             if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3978                 char *p = s;
3979                 if ((PL_bufend - p) >= 3 &&
3980                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3981                     p += 2;
3982                 else if ((PL_bufend - p) >= 4 &&
3983                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
3984                     p += 3;
3985                 p = skipspace(p);
3986                 if (isIDFIRST_lazy(p)) {
3987                     p = scan_ident(p, PL_bufend,
3988                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3989                     p = skipspace(p);
3990                 }
3991                 if (*p != '$')
3992                     Perl_croak(aTHX_ "Missing $ on loop variable");
3993             }
3994             OPERATOR(FOR);
3995
3996         case KEY_formline:
3997             LOP(OP_FORMLINE,XTERM);
3998
3999         case KEY_fork:
4000             FUN0(OP_FORK);
4001
4002         case KEY_fcntl:
4003             LOP(OP_FCNTL,XTERM);
4004
4005         case KEY_fileno:
4006             UNI(OP_FILENO);
4007
4008         case KEY_flock:
4009             LOP(OP_FLOCK,XTERM);
4010
4011         case KEY_gt:
4012             Rop(OP_SGT);
4013
4014         case KEY_ge:
4015             Rop(OP_SGE);
4016
4017         case KEY_grep:
4018             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
4019
4020         case KEY_goto:
4021             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4022             LOOPX(OP_GOTO);
4023
4024         case KEY_gmtime:
4025             UNI(OP_GMTIME);
4026
4027         case KEY_getc:
4028             UNI(OP_GETC);
4029
4030         case KEY_getppid:
4031             FUN0(OP_GETPPID);
4032
4033         case KEY_getpgrp:
4034             UNI(OP_GETPGRP);
4035
4036         case KEY_getpriority:
4037             LOP(OP_GETPRIORITY,XTERM);
4038
4039         case KEY_getprotobyname:
4040             UNI(OP_GPBYNAME);
4041
4042         case KEY_getprotobynumber:
4043             LOP(OP_GPBYNUMBER,XTERM);
4044
4045         case KEY_getprotoent:
4046             FUN0(OP_GPROTOENT);
4047
4048         case KEY_getpwent:
4049             FUN0(OP_GPWENT);
4050
4051         case KEY_getpwnam:
4052             UNI(OP_GPWNAM);
4053
4054         case KEY_getpwuid:
4055             UNI(OP_GPWUID);
4056
4057         case KEY_getpeername:
4058             UNI(OP_GETPEERNAME);
4059
4060         case KEY_gethostbyname:
4061             UNI(OP_GHBYNAME);
4062
4063         case KEY_gethostbyaddr:
4064             LOP(OP_GHBYADDR,XTERM);
4065
4066         case KEY_gethostent:
4067             FUN0(OP_GHOSTENT);
4068
4069         case KEY_getnetbyname:
4070             UNI(OP_GNBYNAME);
4071
4072         case KEY_getnetbyaddr:
4073             LOP(OP_GNBYADDR,XTERM);
4074
4075         case KEY_getnetent:
4076             FUN0(OP_GNETENT);
4077
4078         case KEY_getservbyname:
4079             LOP(OP_GSBYNAME,XTERM);
4080
4081         case KEY_getservbyport:
4082             LOP(OP_GSBYPORT,XTERM);
4083
4084         case KEY_getservent:
4085             FUN0(OP_GSERVENT);
4086
4087         case KEY_getsockname:
4088             UNI(OP_GETSOCKNAME);
4089
4090         case KEY_getsockopt:
4091             LOP(OP_GSOCKOPT,XTERM);
4092
4093         case KEY_getgrent:
4094             FUN0(OP_GGRENT);
4095
4096         case KEY_getgrnam:
4097             UNI(OP_GGRNAM);
4098
4099         case KEY_getgrgid:
4100             UNI(OP_GGRGID);
4101
4102         case KEY_getlogin:
4103             FUN0(OP_GETLOGIN);
4104
4105         case KEY_glob:
4106             set_csh();
4107             LOP(OP_GLOB,XTERM);
4108
4109         case KEY_hex:
4110             UNI(OP_HEX);
4111
4112         case KEY_if:
4113             yylval.ival = PL_curcop->cop_line;
4114             OPERATOR(IF);
4115
4116         case KEY_index:
4117             LOP(OP_INDEX,XTERM);
4118
4119         case KEY_int:
4120             UNI(OP_INT);
4121
4122         case KEY_ioctl:
4123             LOP(OP_IOCTL,XTERM);
4124
4125         case KEY_join:
4126             LOP(OP_JOIN,XTERM);
4127
4128         case KEY_keys:
4129             UNI(OP_KEYS);
4130
4131         case KEY_kill:
4132             LOP(OP_KILL,XTERM);
4133
4134         case KEY_last:
4135             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4136             LOOPX(OP_LAST);
4137
4138         case KEY_lc:
4139             UNI(OP_LC);
4140
4141         case KEY_lcfirst:
4142             UNI(OP_LCFIRST);
4143
4144         case KEY_local:
4145             yylval.ival = 0;
4146             OPERATOR(LOCAL);
4147
4148         case KEY_length:
4149             UNI(OP_LENGTH);
4150
4151         case KEY_lt:
4152             Rop(OP_SLT);
4153
4154         case KEY_le:
4155             Rop(OP_SLE);
4156
4157         case KEY_localtime:
4158             UNI(OP_LOCALTIME);
4159
4160         case KEY_log:
4161             UNI(OP_LOG);
4162
4163         case KEY_link:
4164             LOP(OP_LINK,XTERM);
4165
4166         case KEY_listen:
4167             LOP(OP_LISTEN,XTERM);
4168
4169         case KEY_lock:
4170             UNI(OP_LOCK);
4171
4172         case KEY_lstat:
4173             UNI(OP_LSTAT);
4174
4175         case KEY_m:
4176             s = scan_pat(s,OP_MATCH);
4177             TERM(sublex_start());
4178
4179         case KEY_map:
4180             LOP(OP_MAPSTART, *s == '(' ? XTERM : XREF);
4181
4182         case KEY_mkdir:
4183             LOP(OP_MKDIR,XTERM);
4184
4185         case KEY_msgctl:
4186             LOP(OP_MSGCTL,XTERM);
4187
4188         case KEY_msgget:
4189             LOP(OP_MSGGET,XTERM);
4190
4191         case KEY_msgrcv:
4192             LOP(OP_MSGRCV,XTERM);
4193
4194         case KEY_msgsnd:
4195             LOP(OP_MSGSND,XTERM);
4196
4197         case KEY_our:
4198         case KEY_my:
4199             PL_in_my = tmp;
4200             s = skipspace(s);
4201             if (isIDFIRST_lazy(s)) {
4202                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4203                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4204                     goto really_sub;
4205                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4206                 if (!PL_in_my_stash) {
4207                     char tmpbuf[1024];
4208                     PL_bufptr = s;
4209                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4210                     yyerror(tmpbuf);
4211                 }
4212             }
4213             yylval.ival = 1;
4214             OPERATOR(MY);
4215
4216         case KEY_next:
4217             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4218             LOOPX(OP_NEXT);
4219
4220         case KEY_ne:
4221             Eop(OP_SNE);
4222
4223         case KEY_no:
4224             if (PL_expect != XSTATE)
4225                 yyerror("\"no\" not allowed in expression");
4226             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4227             s = force_version(s);
4228             yylval.ival = 0;
4229             OPERATOR(USE);
4230
4231         case KEY_not:
4232             if (*s == '(' || (s = skipspace(s), *s == '('))
4233                 FUN1(OP_NOT);
4234             else
4235                 OPERATOR(NOTOP);
4236
4237         case KEY_open:
4238             s = skipspace(s);
4239             if (isIDFIRST_lazy(s)) {
4240                 char *t;
4241                 for (d = s; isALNUM_lazy(d); d++) ;
4242                 t = skipspace(d);
4243                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4244                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4245                            "Precedence problem: open %.*s should be open(%.*s)",
4246                             d-s,s, d-s,s);
4247             }
4248             LOP(OP_OPEN,XTERM);
4249
4250         case KEY_or:
4251             yylval.ival = OP_OR;
4252             OPERATOR(OROP);
4253
4254         case KEY_ord:
4255             UNI(OP_ORD);
4256
4257         case KEY_oct:
4258             UNI(OP_OCT);
4259
4260         case KEY_opendir:
4261             LOP(OP_OPEN_DIR,XTERM);
4262
4263         case KEY_print:
4264             checkcomma(s,PL_tokenbuf,"filehandle");
4265             LOP(OP_PRINT,XREF);
4266
4267         case KEY_printf:
4268             checkcomma(s,PL_tokenbuf,"filehandle");
4269             LOP(OP_PRTF,XREF);
4270
4271         case KEY_prototype:
4272             UNI(OP_PROTOTYPE);
4273
4274         case KEY_push:
4275             LOP(OP_PUSH,XTERM);
4276
4277         case KEY_pop:
4278             UNI(OP_POP);
4279
4280         case KEY_pos:
4281             UNI(OP_POS);
4282
4283         case KEY_pack:
4284             LOP(OP_PACK,XTERM);
4285
4286         case KEY_package:
4287             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4288             OPERATOR(PACKAGE);
4289
4290         case KEY_pipe:
4291             LOP(OP_PIPE_OP,XTERM);
4292
4293         case KEY_q:
4294             s = scan_str(s,FALSE,FALSE);
4295             if (!s)
4296                 missingterm((char*)0);
4297             yylval.ival = OP_CONST;
4298             TERM(sublex_start());
4299
4300         case KEY_quotemeta:
4301             UNI(OP_QUOTEMETA);
4302
4303         case KEY_qw:
4304             s = scan_str(s,FALSE,FALSE);
4305             if (!s)
4306                 missingterm((char*)0);
4307             force_next(')');
4308             if (SvCUR(PL_lex_stuff)) {
4309                 OP *words = Nullop;
4310                 int warned = 0;
4311                 d = SvPV_force(PL_lex_stuff, len);
4312                 while (len) {
4313                     for (; isSPACE(*d) && len; --len, ++d) ;
4314                     if (len) {
4315                         char *b = d;
4316                         if (!warned && ckWARN(WARN_SYNTAX)) {
4317                             for (; !isSPACE(*d) && len; --len, ++d) {
4318                                 if (*d == ',') {
4319                                     Perl_warner(aTHX_ WARN_SYNTAX,
4320                                         "Possible attempt to separate words with commas");
4321                                     ++warned;
4322                                 }
4323                                 else if (*d == '#') {
4324                                     Perl_warner(aTHX_ WARN_SYNTAX,
4325                                         "Possible attempt to put comments in qw() list");
4326                                     ++warned;
4327                                 }
4328                             }
4329                         }
4330                         else {
4331                             for (; !isSPACE(*d) && len; --len, ++d) ;
4332                         }
4333                         words = append_elem(OP_LIST, words,
4334                                             newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4335                     }
4336                 }
4337                 if (words) {
4338                     PL_nextval[PL_nexttoke].opval = words;
4339                     force_next(THING);
4340                 }
4341             }
4342             if (PL_lex_stuff)
4343                 SvREFCNT_dec(PL_lex_stuff);
4344             PL_lex_stuff = Nullsv;
4345             PL_expect = XTERM;
4346             TOKEN('(');
4347
4348         case KEY_qq:
4349             s = scan_str(s,FALSE,FALSE);
4350             if (!s)
4351                 missingterm((char*)0);
4352             yylval.ival = OP_STRINGIFY;
4353             if (SvIVX(PL_lex_stuff) == '\'')
4354                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4355             TERM(sublex_start());
4356
4357         case KEY_qr:
4358             s = scan_pat(s,OP_QR);
4359             TERM(sublex_start());
4360
4361         case KEY_qx:
4362             s = scan_str(s,FALSE,FALSE);
4363             if (!s)
4364                 missingterm((char*)0);
4365             yylval.ival = OP_BACKTICK;
4366             set_csh();
4367             TERM(sublex_start());
4368
4369         case KEY_return:
4370             OLDLOP(OP_RETURN);
4371
4372         case KEY_require:
4373             *PL_tokenbuf = '\0';
4374             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4375             if (isIDFIRST_lazy(PL_tokenbuf))
4376                 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4377             else if (*s == '<')
4378                 yyerror("<> should be quotes");
4379             UNI(OP_REQUIRE);
4380
4381         case KEY_reset:
4382             UNI(OP_RESET);
4383
4384         case KEY_redo:
4385             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4386             LOOPX(OP_REDO);
4387
4388         case KEY_rename:
4389             LOP(OP_RENAME,XTERM);
4390
4391         case KEY_rand:
4392             UNI(OP_RAND);
4393
4394         case KEY_rmdir:
4395             UNI(OP_RMDIR);
4396
4397         case KEY_rindex:
4398             LOP(OP_RINDEX,XTERM);
4399
4400         case KEY_read:
4401             LOP(OP_READ,XTERM);
4402
4403         case KEY_readdir:
4404             UNI(OP_READDIR);
4405
4406         case KEY_readline:
4407             set_csh();
4408             UNI(OP_READLINE);
4409
4410         case KEY_readpipe:
4411  &n