toke.c

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