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