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_linestr == PL_lex_repl
1853             && SvCOMPILED(PL_lex_repl))
1854         {
1855             if (PL_bufptr != PL_bufend)
1856                 croak("Bad evalled substitution pattern");
1857             PL_lex_repl = Nullsv;
1858         }
1859         /* FALLTHROUGH */
1860     case LEX_INTERPCONCAT:
1861 #ifdef DEBUGGING
1862         if (PL_lex_brackets)
1863             croak("panic: INTERPCONCAT");
1864 #endif
1865         if (PL_bufptr == PL_bufend)
1866             return sublex_done();
1867
1868         if (SvIVX(PL_linestr) == '\'') {
1869             SV *sv = newSVsv(PL_linestr);
1870             if (!PL_lex_inpat)
1871                 sv = tokeq(sv);
1872             else if ( PL_hints & HINT_NEW_RE )
1873                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1874             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1875             s = PL_bufend;
1876         }
1877         else {
1878             s = scan_const(PL_bufptr);
1879             if (*s == '\\')
1880                 PL_lex_state = LEX_INTERPCASEMOD;
1881             else
1882                 PL_lex_state = LEX_INTERPSTART;
1883         }
1884
1885         if (s != PL_bufptr) {
1886             PL_nextval[PL_nexttoke] = yylval;
1887             PL_expect = XTERM;
1888             force_next(THING);
1889             if (PL_lex_starts++)
1890                 Aop(OP_CONCAT);
1891             else {
1892                 PL_bufptr = s;
1893                 return yylex(PERL_YYLEX_PARAM);
1894             }
1895         }
1896
1897         return yylex(PERL_YYLEX_PARAM);
1898     case LEX_FORMLINE:
1899         PL_lex_state = LEX_NORMAL;
1900         s = scan_formline(PL_bufptr);
1901         if (!PL_lex_formbrack)
1902             goto rightbracket;
1903         OPERATOR(';');
1904     }
1905
1906     s = PL_bufptr;
1907     PL_oldoldbufptr = PL_oldbufptr;
1908     PL_oldbufptr = s;
1909     DEBUG_p( {
1910         PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1911     } )
1912
1913   retry:
1914     switch (*s) {
1915     default:
1916         if (isIDFIRST_lazy(s))
1917             goto keylookup;
1918         croak("Unrecognized character \\x%02X", *s & 255);
1919     case 4:
1920     case 26:
1921         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
1922     case 0:
1923         if (!PL_rsfp) {
1924             PL_last_uni = 0;
1925             PL_last_lop = 0;
1926             if (PL_lex_brackets)
1927                 yyerror("Missing right bracket");
1928             TOKEN(0);
1929         }
1930         if (s++ < PL_bufend)
1931             goto retry;                 /* ignore stray nulls */
1932         PL_last_uni = 0;
1933         PL_last_lop = 0;
1934         if (!PL_in_eval && !PL_preambled) {
1935             PL_preambled = TRUE;
1936             sv_setpv(PL_linestr,incl_perldb());
1937             if (SvCUR(PL_linestr))
1938                 sv_catpv(PL_linestr,";");
1939             if (PL_preambleav){
1940                 while(AvFILLp(PL_preambleav) >= 0) {
1941                     SV *tmpsv = av_shift(PL_preambleav);
1942                     sv_catsv(PL_linestr, tmpsv);
1943                     sv_catpv(PL_linestr, ";");
1944                     sv_free(tmpsv);
1945                 }
1946                 sv_free((SV*)PL_preambleav);
1947                 PL_preambleav = NULL;
1948             }
1949             if (PL_minus_n || PL_minus_p) {
1950                 sv_catpv(PL_linestr, "LINE: while (<>) {");
1951                 if (PL_minus_l)
1952                     sv_catpv(PL_linestr,"chomp;");
1953                 if (PL_minus_a) {
1954                     GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1955                     if (gv)
1956                         GvIMPORTED_AV_on(gv);
1957                     if (PL_minus_F) {
1958                         if (strchr("/'\"", *PL_splitstr)
1959                               && strchr(PL_splitstr + 1, *PL_splitstr))
1960                             sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1961                         else {
1962                             char delim;
1963                             s = "'~#\200\1'"; /* surely one char is unused...*/
1964                             while (s[1] && strchr(PL_splitstr, *s))  s++;
1965                             delim = *s;
1966                             sv_catpvf(PL_linestr, "@F=split(%s%c",
1967                                       "q" + (delim == '\''), delim);
1968                             for (s = PL_splitstr; *s; s++) {
1969                                 if (*s == '\\')
1970                                     sv_catpvn(PL_linestr, "\\", 1);
1971                                 sv_catpvn(PL_linestr, s, 1);
1972                             }
1973                             sv_catpvf(PL_linestr, "%c);", delim);
1974                         }
1975                     }
1976                     else
1977                         sv_catpv(PL_linestr,"@F=split(' ');");
1978                 }
1979             }
1980             sv_catpv(PL_linestr, "\n");
1981             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1982             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1983             if (PERLDB_LINE && PL_curstash != PL_debstash) {
1984                 SV *sv = NEWSV(85,0);
1985
1986                 sv_upgrade(sv, SVt_PVMG);
1987                 sv_setsv(sv,PL_linestr);
1988                 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1989             }
1990             goto retry;
1991         }
1992         do {
1993             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1994               fake_eof:
1995                 if (PL_rsfp) {
1996                     if (PL_preprocess && !PL_in_eval)
1997                         (void)PerlProc_pclose(PL_rsfp);
1998                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1999                         PerlIO_clearerr(PL_rsfp);
2000                     else
2001                         (void)PerlIO_close(PL_rsfp);
2002                     PL_rsfp = Nullfp;
2003                     PL_doextract = FALSE;
2004                 }
2005                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2006                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2007                     sv_catpv(PL_linestr,";}");
2008                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2009                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2010                     PL_minus_n = PL_minus_p = 0;
2011                     goto retry;
2012                 }
2013                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2014                 sv_setpv(PL_linestr,"");
2015                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2016             }
2017             if (PL_doextract) {
2018                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2019                     PL_doextract = FALSE;
2020
2021                 /* Incest with pod. */
2022                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2023                     sv_setpv(PL_linestr, "");
2024                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2025                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2026                     PL_doextract = FALSE;
2027                 }
2028             }
2029             incline(s);
2030         } while (PL_doextract);
2031         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2032         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2033             SV *sv = NEWSV(85,0);
2034
2035             sv_upgrade(sv, SVt_PVMG);
2036             sv_setsv(sv,PL_linestr);
2037             av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2038         }
2039         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2040         if (PL_curcop->cop_line == 1) {
2041             while (s < PL_bufend && isSPACE(*s))
2042                 s++;
2043             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2044                 s++;
2045             d = Nullch;
2046             if (!PL_in_eval) {
2047                 if (*s == '#' && *(s+1) == '!')
2048                     d = s + 2;
2049 #ifdef ALTERNATE_SHEBANG
2050                 else {
2051                     static char as[] = ALTERNATE_SHEBANG;
2052                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2053                         d = s + (sizeof(as) - 1);
2054                 }
2055 #endif /* ALTERNATE_SHEBANG */
2056             }
2057             if (d) {
2058                 char *ipath;
2059                 char *ipathend;
2060
2061                 while (isSPACE(*d))
2062                     d++;
2063                 ipath = d;
2064                 while (*d && !isSPACE(*d))
2065                     d++;
2066                 ipathend = d;
2067
2068 #ifdef ARG_ZERO_IS_SCRIPT
2069                 if (ipathend > ipath) {
2070                     /*
2071                      * HP-UX (at least) sets argv[0] to the script name,
2072                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2073                      * at least, set argv[0] to the basename of the Perl
2074                      * interpreter. So, having found "#!", we'll set it right.
2075                      */
2076                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2077                     assert(SvPOK(x) || SvGMAGICAL(x));
2078                     if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2079                         sv_setpvn(x, ipath, ipathend - ipath);
2080                         SvSETMAGIC(x);
2081                     }
2082                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2083                 }
2084 #endif /* ARG_ZERO_IS_SCRIPT */
2085
2086                 /*
2087                  * Look for options.
2088                  */
2089                 d = instr(s,"perl -");
2090                 if (!d)
2091                     d = instr(s,"perl");
2092 #ifdef ALTERNATE_SHEBANG
2093                 /*
2094                  * If the ALTERNATE_SHEBANG on this system starts with a
2095                  * character that can be part of a Perl expression, then if
2096                  * we see it but not "perl", we're probably looking at the
2097                  * start of Perl code, not a request to hand off to some
2098                  * other interpreter.  Similarly, if "perl" is there, but
2099                  * not in the first 'word' of the line, we assume the line
2100                  * contains the start of the Perl program.
2101                  */
2102                 if (d && *s != '#') {
2103                     char *c = ipath;
2104                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2105                         c++;
2106                     if (c < d)
2107                         d = Nullch;     /* "perl" not in first word; ignore */
2108                     else
2109                         *s = '#';       /* Don't try to parse shebang line */
2110                 }
2111 #endif /* ALTERNATE_SHEBANG */
2112                 if (!d &&
2113                     *s == '#' &&
2114                     ipathend > ipath &&
2115                     !PL_minus_c &&
2116                     !instr(s,"indir") &&
2117                     instr(PL_origargv[0],"perl"))
2118                 {
2119                     char **newargv;
2120
2121                     *ipathend = '\0';
2122                     s = ipathend + 1;
2123                     while (s < PL_bufend && isSPACE(*s))
2124                         s++;
2125                     if (s < PL_bufend) {
2126                         Newz(899,newargv,PL_origargc+3,char*);
2127                         newargv[1] = s;
2128                         while (s < PL_bufend && !isSPACE(*s))
2129                             s++;
2130                         *s = '\0';
2131                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2132                     }
2133                     else
2134                         newargv = PL_origargv;
2135                     newargv[0] = ipath;
2136                     PerlProc_execv(ipath, newargv);
2137                     croak("Can't exec %s", ipath);
2138                 }
2139                 if (d) {
2140                     U32 oldpdb = PL_perldb;
2141                     bool oldn = PL_minus_n;
2142                     bool oldp = PL_minus_p;
2143
2144                     while (*d && !isSPACE(*d)) d++;
2145                     while (*d == ' ' || *d == '\t') d++;
2146
2147                     if (*d++ == '-') {
2148                         do {
2149                             if (*d == 'M' || *d == 'm') {
2150                                 char *m = d;
2151                                 while (*d && !isSPACE(*d)) d++;
2152                                 croak("Too late for \"-%.*s\" option",
2153                                       (int)(d - m), m);
2154                             }
2155                             d = moreswitches(d);
2156                         } while (d);
2157                         if (PERLDB_LINE && !oldpdb ||
2158                             ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2159                               /* if we have already added "LINE: while (<>) {",
2160                                  we must not do it again */
2161                         {
2162                             sv_setpv(PL_linestr, "");
2163                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2164                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2165                             PL_preambled = FALSE;
2166                             if (PERLDB_LINE)
2167                                 (void)gv_fetchfile(PL_origfilename);
2168                             goto retry;
2169                         }
2170                     }
2171                 }
2172             }
2173         }
2174         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2175             PL_bufptr = s;
2176             PL_lex_state = LEX_FORMLINE;
2177             return yylex(PERL_YYLEX_PARAM);
2178         }
2179         goto retry;
2180     case '\r':
2181 #ifdef PERL_STRICT_CR
2182         warn("Illegal character \\%03o (carriage return)", '\r');
2183         croak(
2184       "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2185 #endif
2186     case ' ': case '\t': case '\f': case 013:
2187         s++;
2188         goto retry;
2189     case '#':
2190     case '\n':
2191         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2192             d = PL_bufend;
2193             while (s < d && *s != '\n')
2194                 s++;
2195             if (s < d)
2196                 s++;
2197             incline(s);
2198             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2199                 PL_bufptr = s;
2200                 PL_lex_state = LEX_FORMLINE;
2201                 return yylex(PERL_YYLEX_PARAM);
2202             }
2203         }
2204         else {
2205             *s = '\0';
2206             PL_bufend = s;
2207         }
2208         goto retry;
2209     case '-':
2210         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2211             s++;
2212             PL_bufptr = s;
2213             tmp = *s++;
2214
2215             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2216                 s++;
2217
2218             if (strnEQ(s,"=>",2)) {
2219                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2220                 OPERATOR('-');          /* unary minus */
2221             }
2222             PL_last_uni = PL_oldbufptr;
2223             PL_last_lop_op = OP_FTEREAD;        /* good enough */
2224             switch (tmp) {
2225             case 'r': FTST(OP_FTEREAD);
2226             case 'w': FTST(OP_FTEWRITE);
2227             case 'x': FTST(OP_FTEEXEC);
2228             case 'o': FTST(OP_FTEOWNED);
2229             case 'R': FTST(OP_FTRREAD);
2230             case 'W': FTST(OP_FTRWRITE);
2231             case 'X': FTST(OP_FTREXEC);
2232             case 'O': FTST(OP_FTROWNED);
2233             case 'e': FTST(OP_FTIS);
2234             case 'z': FTST(OP_FTZERO);
2235             case 's': FTST(OP_FTSIZE);
2236             case 'f': FTST(OP_FTFILE);
2237             case 'd': FTST(OP_FTDIR);
2238             case 'l': FTST(OP_FTLINK);
2239             case 'p': FTST(OP_FTPIPE);
2240             case 'S': FTST(OP_FTSOCK);
2241             case 'u': FTST(OP_FTSUID);
2242             case 'g': FTST(OP_FTSGID);
2243             case 'k': FTST(OP_FTSVTX);
2244             case 'b': FTST(OP_FTBLK);
2245             case 'c': FTST(OP_FTCHR);
2246             case 't': FTST(OP_FTTTY);
2247             case 'T': FTST(OP_FTTEXT);
2248             case 'B': FTST(OP_FTBINARY);
2249             case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2250             case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2251             case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2252             default:
2253                 croak("Unrecognized file test: -%c", (int)tmp);
2254                 break;
2255             }
2256         }
2257         tmp = *s++;
2258         if (*s == tmp) {
2259             s++;
2260             if (PL_expect == XOPERATOR)
2261                 TERM(POSTDEC);
2262             else
2263                 OPERATOR(PREDEC);
2264         }
2265         else if (*s == '>') {
2266             s++;
2267             s = skipspace(s);
2268             if (isIDFIRST_lazy(s)) {
2269                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2270                 TOKEN(ARROW);
2271             }
2272             else if (*s == '$')
2273                 OPERATOR(ARROW);
2274             else
2275                 TERM(ARROW);
2276         }
2277         if (PL_expect == XOPERATOR)
2278             Aop(OP_SUBTRACT);
2279         else {
2280             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2281                 check_uni();
2282             OPERATOR('-');              /* unary minus */
2283         }
2284
2285     case '+':
2286         tmp = *s++;
2287         if (*s == tmp) {
2288             s++;
2289             if (PL_expect == XOPERATOR)
2290                 TERM(POSTINC);
2291             else
2292                 OPERATOR(PREINC);
2293         }
2294         if (PL_expect == XOPERATOR)
2295             Aop(OP_ADD);
2296         else {
2297             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2298                 check_uni();
2299             OPERATOR('+');
2300         }
2301
2302     case '*':
2303         if (PL_expect != XOPERATOR) {
2304             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2305             PL_expect = XOPERATOR;
2306             force_ident(PL_tokenbuf, '*');
2307             if (!*PL_tokenbuf)
2308                 PREREF('*');
2309             TERM('*');
2310         }
2311         s++;
2312         if (*s == '*') {
2313             s++;
2314             PWop(OP_POW);
2315         }
2316         Mop(OP_MULTIPLY);
2317
2318     case '%':
2319         if (PL_expect == XOPERATOR) {
2320             ++s;
2321             Mop(OP_MODULO);
2322         }
2323         PL_tokenbuf[0] = '%';
2324         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2325         if (!PL_tokenbuf[1]) {
2326             if (s == PL_bufend)
2327                 yyerror("Final % should be \\% or %name");
2328             PREREF('%');
2329         }
2330         PL_pending_ident = '%';
2331         TERM('%');
2332
2333     case '^':
2334         s++;
2335         BOop(OP_BIT_XOR);
2336     case '[':
2337         PL_lex_brackets++;
2338         /* FALL THROUGH */
2339     case '~':
2340     case ',':
2341         tmp = *s++;
2342         OPERATOR(tmp);
2343     case ':':
2344         if (s[1] == ':') {
2345             len = 0;
2346             goto just_a_word;
2347         }
2348         s++;
2349         OPERATOR(':');
2350     case '(':
2351         s++;
2352         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2353             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
2354         else
2355             PL_expect = XTERM;
2356         TOKEN('(');
2357     case ';':
2358         if (PL_curcop->cop_line < PL_copline)
2359             PL_copline = PL_curcop->cop_line;
2360         tmp = *s++;
2361         OPERATOR(tmp);
2362     case ')':
2363         tmp = *s++;
2364         s = skipspace(s);
2365         if (*s == '{')
2366             PREBLOCK(tmp);
2367         TERM(tmp);
2368     case ']':
2369         s++;
2370         if (PL_lex_brackets <= 0)
2371             yyerror("Unmatched right bracket");
2372         else
2373             --PL_lex_brackets;
2374         if (PL_lex_state == LEX_INTERPNORMAL) {
2375             if (PL_lex_brackets == 0) {
2376                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2377                     PL_lex_state = LEX_INTERPEND;
2378             }
2379         }
2380         TERM(']');
2381     case '{':
2382       leftbracket:
2383         s++;
2384         if (PL_lex_brackets > 100) {
2385             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2386             if (newlb != PL_lex_brackstack) {
2387                 SAVEFREEPV(newlb);
2388                 PL_lex_brackstack = newlb;
2389             }
2390         }
2391         switch (PL_expect) {
2392         case XTERM:
2393             if (PL_lex_formbrack) {
2394                 s--;
2395                 PRETERMBLOCK(DO);
2396             }
2397             if (PL_oldoldbufptr == PL_last_lop)
2398                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2399             else
2400                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2401             OPERATOR(HASHBRACK);
2402         case XOPERATOR:
2403             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2404                 s++;
2405             d = s;
2406             PL_tokenbuf[0] = '\0';
2407             if (d < PL_bufend && *d == '-') {
2408                 PL_tokenbuf[0] = '-';
2409                 d++;
2410                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2411                     d++;
2412             }
2413             if (d < PL_bufend && isIDFIRST_lazy(d)) {
2414                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2415                               FALSE, &len);
2416                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2417                     d++;
2418                 if (*d == '}') {
2419                     char minus = (PL_tokenbuf[0] == '-');
2420                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2421                     if (minus)
2422                         force_next('-');
2423                 }
2424             }
2425             /* FALL THROUGH */
2426         case XBLOCK:
2427             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2428             PL_expect = XSTATE;
2429             break;
2430         case XTERMBLOCK:
2431             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2432             PL_expect = XSTATE;
2433             break;
2434         default: {
2435                 char *t;
2436                 if (PL_oldoldbufptr == PL_last_lop)
2437                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2438                 else
2439                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2440                 s = skipspace(s);
2441                 if (*s == '}')
2442                     OPERATOR(HASHBRACK);
2443                 /* This hack serves to disambiguate a pair of curlies
2444                  * as being a block or an anon hash.  Normally, expectation
2445                  * determines that, but in cases where we're not in a
2446                  * position to expect anything in particular (like inside
2447                  * eval"") we have to resolve the ambiguity.  This code
2448                  * covers the case where the first term in the curlies is a
2449                  * quoted string.  Most other cases need to be explicitly
2450                  * disambiguated by prepending a `+' before the opening
2451                  * curly in order to force resolution as an anon hash.
2452                  *
2453                  * XXX should probably propagate the outer expectation
2454                  * into eval"" to rely less on this hack, but that could
2455                  * potentially break current behavior of eval"".
2456                  * GSAR 97-07-21
2457                  */
2458                 t = s;
2459                 if (*s == '\'' || *s == '"' || *s == '`') {
2460                     /* common case: get past first string, handling escapes */
2461                     for (t++; t < PL_bufend && *t != *s;)
2462                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
2463                             t++;
2464                     t++;
2465                 }
2466                 else if (*s == 'q') {
2467                     if (++t < PL_bufend
2468                         && (!isALNUM(*t)
2469                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2470                                 && !isALNUM(*t)))) {
2471                         char *tmps;
2472                         char open, close, term;
2473                         I32 brackets = 1;
2474
2475                         while (t < PL_bufend && isSPACE(*t))
2476                             t++;
2477                         term = *t;
2478                         open = term;
2479                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2480                             term = tmps[5];
2481                         close = term;
2482                         if (open == close)
2483                             for (t++; t < PL_bufend; t++) {
2484                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2485                                     t++;
2486                                 else if (*t == open)
2487                                     break;
2488                             }
2489                         else
2490                             for (t++; t < PL_bufend; t++) {
2491                                 if (*t == '\\' && t+1 < PL_bufend)
2492                                     t++;
2493                                 else if (*t == close && --brackets <= 0)
2494                                     break;
2495                                 else if (*t == open)
2496                                     brackets++;
2497                             }
2498                     }
2499                     t++;
2500                 }
2501                 else if (isIDFIRST_lazy(s)) {
2502                     for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2503                 }
2504                 while (t < PL_bufend && isSPACE(*t))
2505                     t++;
2506                 /* if comma follows first term, call it an anon hash */
2507                 /* XXX it could be a comma expression with loop modifiers */
2508                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2509                                    || (*t == '=' && t[1] == '>')))
2510                     OPERATOR(HASHBRACK);
2511                 if (PL_expect == XREF)
2512                     PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2513                 else {
2514                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2515                     PL_expect = XSTATE;
2516                 }
2517             }
2518             break;
2519         }
2520         yylval.ival = PL_curcop->cop_line;
2521         if (isSPACE(*s) || *s == '#')
2522             PL_copline = NOLINE;   /* invalidate current command line number */
2523         TOKEN('{');
2524     case '}':
2525       rightbracket:
2526         s++;
2527         if (PL_lex_brackets <= 0)
2528             yyerror("Unmatched right bracket");
2529         else
2530             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2531         if (PL_lex_brackets < PL_lex_formbrack)
2532             PL_lex_formbrack = 0;
2533         if (PL_lex_state == LEX_INTERPNORMAL) {
2534             if (PL_lex_brackets == 0) {
2535                 if (PL_lex_fakebrack) {
2536                     PL_lex_state = LEX_INTERPEND;
2537                     PL_bufptr = s;
2538                     return yylex(PERL_YYLEX_PARAM);     /* ignore fake brackets */
2539                 }
2540                 if (*s == '-' && s[1] == '>')
2541                     PL_lex_state = LEX_INTERPENDMAYBE;
2542                 else if (*s != '[' && *s != '{')
2543                     PL_lex_state = LEX_INTERPEND;
2544             }
2545         }
2546         if (PL_lex_brackets < PL_lex_fakebrack) {
2547             PL_bufptr = s;
2548             PL_lex_fakebrack = 0;
2549             return yylex(PERL_YYLEX_PARAM);             /* ignore fake brackets */
2550         }
2551         force_next('}');
2552         TOKEN(';');
2553     case '&':
2554         s++;
2555         tmp = *s++;
2556         if (tmp == '&')
2557             AOPERATOR(ANDAND);
2558         s--;
2559         if (PL_expect == XOPERATOR) {
2560             if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2561                 PL_curcop->cop_line--;
2562                 warner(WARN_SEMICOLON, PL_warn_nosemi);
2563                 PL_curcop->cop_line++;
2564             }
2565             BAop(OP_BIT_AND);
2566         }
2567
2568         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2569         if (*PL_tokenbuf) {
2570             PL_expect = XOPERATOR;
2571             force_ident(PL_tokenbuf, '&');
2572         }
2573         else
2574             PREREF('&');
2575         yylval.ival = (OPpENTERSUB_AMPER<<8);
2576         TERM('&');
2577
2578     case '|':
2579         s++;
2580         tmp = *s++;
2581         if (tmp == '|')
2582             AOPERATOR(OROR);
2583         s--;
2584         BOop(OP_BIT_OR);
2585     case '=':
2586         s++;
2587         tmp = *s++;
2588         if (tmp == '=')
2589             Eop(OP_EQ);
2590         if (tmp == '>')
2591             OPERATOR(',');
2592         if (tmp == '~')
2593             PMop(OP_MATCH);
2594         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2595             warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2596         s--;
2597         if (PL_expect == XSTATE && isALPHA(tmp) &&
2598                 (s == PL_linestart+1 || s[-2] == '\n') )
2599         {
2600             if (PL_in_eval && !PL_rsfp) {
2601                 d = PL_bufend;
2602                 while (s < d) {
2603                     if (*s++ == '\n') {
2604                         incline(s);
2605                         if (strnEQ(s,"=cut",4)) {
2606                             s = strchr(s,'\n');
2607                             if (s)
2608                                 s++;
2609                             else
2610                                 s = d;
2611                             incline(s);
2612                             goto retry;
2613                         }
2614                     }
2615                 }
2616                 goto retry;
2617             }
2618             s = PL_bufend;
2619             PL_doextract = TRUE;
2620             goto retry;
2621         }
2622         if (PL_lex_brackets < PL_lex_formbrack) {
2623             char *t;
2624 #ifdef PERL_STRICT_CR
2625             for (t = s; *t == ' ' || *t == '\t'; t++) ;
2626 #else
2627             for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2628 #endif
2629             if (*t == '\n' || *t == '#') {
2630                 s--;
2631                 PL_expect = XBLOCK;
2632                 goto leftbracket;
2633             }
2634         }
2635         yylval.ival = 0;
2636         OPERATOR(ASSIGNOP);
2637     case '!':
2638         s++;
2639         tmp = *s++;
2640         if (tmp == '=')
2641             Eop(OP_NE);
2642         if (tmp == '~')
2643             PMop(OP_NOT);
2644         s--;
2645         OPERATOR('!');
2646     case '<':
2647         if (PL_expect != XOPERATOR) {
2648             if (s[1] != '<' && !strchr(s,'>'))
2649                 check_uni();
2650             if (s[1] == '<')
2651                 s = scan_heredoc(s);
2652             else
2653                 s = scan_inputsymbol(s);
2654             TERM(sublex_start());
2655         }
2656         s++;
2657         tmp = *s++;
2658         if (tmp == '<')
2659             SHop(OP_LEFT_SHIFT);
2660         if (tmp == '=') {
2661             tmp = *s++;
2662             if (tmp == '>')
2663                 Eop(OP_NCMP);
2664             s--;
2665             Rop(OP_LE);
2666         }
2667         s--;
2668         Rop(OP_LT);
2669     case '>':
2670         s++;
2671         tmp = *s++;
2672         if (tmp == '>')
2673             SHop(OP_RIGHT_SHIFT);
2674         if (tmp == '=')
2675             Rop(OP_GE);
2676         s--;
2677         Rop(OP_GT);
2678
2679     case '$':
2680         CLINE;
2681
2682         if (PL_expect == XOPERATOR) {
2683             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2684                 PL_expect = XTERM;
2685                 depcom();
2686                 return ','; /* grandfather non-comma-format format */
2687             }
2688         }
2689
2690         if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2691             if (PL_expect == XOPERATOR)
2692                 no_op("Array length", PL_bufptr);
2693             PL_tokenbuf[0] = '@';
2694             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2695                            FALSE);
2696             if (!PL_tokenbuf[1])
2697                 PREREF(DOLSHARP);
2698             PL_expect = XOPERATOR;
2699             PL_pending_ident = '#';
2700             TOKEN(DOLSHARP);
2701         }
2702
2703         if (PL_expect == XOPERATOR)
2704             no_op("Scalar", PL_bufptr);
2705         PL_tokenbuf[0] = '$';
2706         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2707         if (!PL_tokenbuf[1]) {
2708             if (s == PL_bufend)
2709                 yyerror("Final $ should be \\$ or $name");
2710             PREREF('$');
2711         }
2712
2713         /* This kludge not intended to be bulletproof. */
2714         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2715             yylval.opval = newSVOP(OP_CONST, 0,
2716                                    newSViv((IV)PL_compiling.cop_arybase));
2717             yylval.opval->op_private = OPpCONST_ARYBASE;
2718             TERM(THING);
2719         }
2720
2721         d = s;
2722         if (PL_lex_state == LEX_NORMAL)
2723             s = skipspace(s);
2724
2725         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2726             char *t;
2727             if (*s == '[') {
2728                 PL_tokenbuf[0] = '@';
2729                 if (ckWARN(WARN_SYNTAX)) {
2730                     for(t = s + 1;
2731                         isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2732                         t++) ;
2733                     if (*t++ == ',') {
2734                         PL_bufptr = skipspace(PL_bufptr);
2735                         while (t < PL_bufend && *t != ']')
2736                             t++;
2737                         warner(WARN_SYNTAX,
2738                                 "Multidimensional syntax %.*s not supported",
2739                                 (t - PL_bufptr) + 1, PL_bufptr);
2740                     }
2741                 }
2742             }
2743             else if (*s == '{') {
2744                 PL_tokenbuf[0] = '%';
2745                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2746                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
2747                 {
2748                     char tmpbuf[sizeof PL_tokenbuf];
2749                     STRLEN len;
2750                     for (t++; isSPACE(*t); t++) ;
2751                     if (isIDFIRST_lazy(t)) {
2752                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2753                         for (; isSPACE(*t); t++) ;
2754                         if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
2755                             warner(WARN_SYNTAX,
2756                                 "You need to quote \"%s\"", tmpbuf);
2757                     }
2758                 }
2759             }
2760         }
2761
2762         PL_expect = XOPERATOR;
2763         if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2764             bool islop = (PL_last_lop == PL_oldoldbufptr);
2765             if (!islop || PL_last_lop_op == OP_GREPSTART)
2766                 PL_expect = XOPERATOR;
2767             else if (strchr("$@\"'`q", *s))
2768                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
2769             else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2770                 PL_expect = XTERM;              /* e.g. print $fh &sub */
2771             else if (isIDFIRST_lazy(s)) {
2772                 char tmpbuf[sizeof PL_tokenbuf];
2773                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2774                 if (tmp = keyword(tmpbuf, len)) {
2775                     /* binary operators exclude handle interpretations */
2776                     switch (tmp) {
2777                     case -KEY_x:
2778                     case -KEY_eq:
2779                     case -KEY_ne:
2780                     case -KEY_gt:
2781                     case -KEY_lt:
2782                     case -KEY_ge:
2783                     case -KEY_le:
2784                     case -KEY_cmp:
2785                         break;
2786                     default:
2787                         PL_expect = XTERM;      /* e.g. print $fh length() */
2788                         break;
2789                     }
2790                 }
2791                 else {
2792                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2793                     if (gv && GvCVu(gv))
2794                         PL_expect = XTERM;      /* e.g. print $fh subr() */
2795                 }
2796             }
2797             else if (isDIGIT(*s))
2798                 PL_expect = XTERM;              /* e.g. print $fh 3 */
2799             else if (*s == '.' && isDIGIT(s[1]))
2800                 PL_expect = XTERM;              /* e.g. print $fh .3 */
2801             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2802                 PL_expect = XTERM;              /* e.g. print $fh -1 */
2803             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2804                 PL_expect = XTERM;              /* print $fh <<"EOF" */
2805         }
2806         PL_pending_ident = '$';
2807         TOKEN('$');
2808
2809     case '@':
2810         if (PL_expect == XOPERATOR)
2811             no_op("Array", s);
2812         PL_tokenbuf[0] = '@';
2813         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2814         if (!PL_tokenbuf[1]) {
2815             if (s == PL_bufend)
2816                 yyerror("Final @ should be \\@ or @name");
2817             PREREF('@');
2818         }
2819         if (PL_lex_state == LEX_NORMAL)
2820             s = skipspace(s);
2821         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2822             if (*s == '{')
2823                 PL_tokenbuf[0] = '%';
2824
2825             /* Warn about @ where they meant $. */
2826             if (ckWARN(WARN_SYNTAX)) {
2827                 if (*s == '[' || *s == '{') {
2828                     char *t = s + 1;
2829                     while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2830                         t++;
2831                     if (*t == '}' || *t == ']') {
2832                         t++;
2833                         PL_bufptr = skipspace(PL_bufptr);
2834                         warner(WARN_SYNTAX,
2835                             "Scalar value %.*s better written as $%.*s",
2836                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2837                     }
2838                 }
2839             }
2840         }
2841         PL_pending_ident = '@';
2842         TERM('@');
2843
2844     case '/':                   /* may either be division or pattern */
2845     case '?':                   /* may either be conditional or pattern */
2846         if (PL_expect != XOPERATOR) {
2847             /* Disable warning on "study /blah/" */
2848             if (PL_oldoldbufptr == PL_last_uni
2849                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2850                     || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2851                 check_uni();
2852             s = scan_pat(s,OP_MATCH);
2853             TERM(sublex_start());
2854         }
2855         tmp = *s++;
2856         if (tmp == '/')
2857             Mop(OP_DIVIDE);
2858         OPERATOR(tmp);
2859
2860     case '.':
2861         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2862 #ifdef PERL_STRICT_CR
2863             && s[1] == '\n'
2864 #else
2865             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2866 #endif
2867             && (s == PL_linestart || s[-1] == '\n') )
2868         {
2869             PL_lex_formbrack = 0;
2870             PL_expect = XSTATE;
2871             goto rightbracket;
2872         }
2873         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2874             tmp = *s++;
2875             if (*s == tmp) {
2876                 s++;
2877                 if (*s == tmp) {
2878                     s++;
2879                     yylval.ival = OPf_SPECIAL;
2880                 }
2881                 else
2882                     yylval.ival = 0;
2883                 OPERATOR(DOTDOT);
2884             }
2885             if (PL_expect != XOPERATOR)
2886                 check_uni();
2887             Aop(OP_CONCAT);
2888         }
2889         /* FALL THROUGH */
2890     case '0': case '1': case '2': case '3': case '4':
2891     case '5': case '6': case '7': case '8': case '9':
2892         s = scan_num(s);
2893         if (PL_expect == XOPERATOR)
2894             no_op("Number",s);
2895         TERM(THING);
2896
2897     case '\'':
2898         s = scan_str(s);
2899         if (PL_expect == XOPERATOR) {
2900             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2901                 PL_expect = XTERM;
2902                 depcom();
2903                 return ',';     /* grandfather non-comma-format format */
2904             }
2905             else
2906                 no_op("String",s);
2907         }
2908         if (!s)
2909             missingterm((char*)0);
2910         yylval.ival = OP_CONST;
2911         TERM(sublex_start());
2912
2913     case '"':
2914         s = scan_str(s);
2915         if (PL_expect == XOPERATOR) {
2916             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2917                 PL_expect = XTERM;
2918                 depcom();
2919                 return ',';     /* grandfather non-comma-format format */
2920             }
2921             else
2922                 no_op("String",s);
2923         }
2924         if (!s)
2925             missingterm((char*)0);
2926         yylval.ival = OP_CONST;
2927         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2928             if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2929                 yylval.ival = OP_STRINGIFY;
2930                 break;
2931             }
2932         }
2933         TERM(sublex_start());
2934
2935     case '`':
2936         s = scan_str(s);
2937         if (PL_expect == XOPERATOR)
2938             no_op("Backticks",s);
2939         if (!s)
2940             missingterm((char*)0);
2941         yylval.ival = OP_BACKTICK;
2942         set_csh();
2943         TERM(sublex_start());
2944
2945     case '\\':
2946         s++;
2947         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2948             warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2949                         *s, *s);
2950         if (PL_expect == XOPERATOR)
2951             no_op("Backslash",s);
2952         OPERATOR(REFGEN);
2953
2954     case 'x':
2955         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2956             s++;
2957             Mop(OP_REPEAT);
2958         }
2959         goto keylookup;
2960
2961     case '_':
2962     case 'a': case 'A':
2963     case 'b': case 'B':
2964     case 'c': case 'C':
2965     case 'd': case 'D':
2966     case 'e': case 'E':
2967     case 'f': case 'F':
2968     case 'g': case 'G':
2969     case 'h': case 'H':
2970     case 'i': case 'I':
2971     case 'j': case 'J':
2972     case 'k': case 'K':
2973     case 'l': case 'L':
2974     case 'm': case 'M':
2975     case 'n': case 'N':
2976     case 'o': case 'O':
2977     case 'p': case 'P':
2978     case 'q': case 'Q':
2979     case 'r': case 'R':
2980     case 's': case 'S':
2981     case 't': case 'T':
2982     case 'u': case 'U':
2983     case 'v': case 'V':
2984     case 'w': case 'W':
2985               case 'X':
2986     case 'y': case 'Y':
2987     case 'z': case 'Z':
2988
2989       keylookup: {
2990         STRLEN n_a;
2991         gv = Nullgv;
2992         gvp = 0;
2993
2994         PL_bufptr = s;
2995         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2996
2997         /* Some keywords can be followed by any delimiter, including ':' */
2998         tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2999                len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3000                             (PL_tokenbuf[0] == 'q' &&
3001                              strchr("qwxr", PL_tokenbuf[1]))));
3002
3003         /* x::* is just a word, unless x is "CORE" */
3004         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3005             goto just_a_word;
3006
3007         d = s;
3008         while (d < PL_bufend && isSPACE(*d))
3009                 d++;    /* no comments skipped here, or s### is misparsed */
3010
3011         /* Is this a label? */
3012         if (!tmp && PL_expect == XSTATE
3013               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3014             s = d + 1;
3015             yylval.pval = savepv(PL_tokenbuf);
3016             CLINE;
3017             TOKEN(LABEL);
3018         }
3019
3020         /* Check for keywords */
3021         tmp = keyword(PL_tokenbuf, len);
3022
3023         /* Is this a word before a => operator? */
3024         if (strnEQ(d,"=>",2)) {
3025             CLINE;
3026             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3027             yylval.opval->op_private = OPpCONST_BARE;
3028             TERM(WORD);
3029         }
3030
3031         if (tmp < 0) {                  /* second-class keyword? */
3032             GV *ogv = Nullgv;   /* override (winner) */
3033             GV *hgv = Nullgv;   /* hidden (loser) */
3034             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3035                 CV *cv;
3036                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3037                     (cv = GvCVu(gv)))
3038                 {
3039                     if (GvIMPORTED_CV(gv))
3040                         ogv = gv;
3041                     else if (! CvMETHOD(cv))
3042                         hgv = gv;
3043                 }
3044                 if (!ogv &&
3045                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3046                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3047                     GvCVu(gv) && GvIMPORTED_CV(gv))
3048                 {
3049                     ogv = gv;
3050                 }
3051             }
3052             if (ogv) {
3053                 tmp = 0;                /* overridden by import or by GLOBAL */
3054             }
3055             else if (gv && !gvp
3056                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3057                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3058             {
3059                 tmp = 0;                /* any sub overrides "weak" keyword */
3060             }
3061             else {                      /* no override */
3062                 tmp = -tmp;
3063                 gv = Nullgv;
3064                 gvp = 0;
3065                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3066                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3067                     warner(WARN_AMBIGUOUS,
3068                         "Ambiguous call resolved as CORE::%s(), %s",
3069                          GvENAME(hgv), "qualify as such or use &");
3070             }
3071         }
3072
3073       reserved_word:
3074         switch (tmp) {
3075
3076         default:                        /* not a keyword */
3077           just_a_word: {
3078                 SV *sv;
3079                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3080
3081                 /* Get the rest if it looks like a package qualifier */
3082
3083                 if (*s == '\'' || *s == ':' && s[1] == ':') {
3084                     STRLEN morelen;
3085                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3086                                   TRUE, &morelen);
3087                     if (!morelen)
3088                         croak("Bad name after %s%s", PL_tokenbuf,
3089                                 *s == '\'' ? "'" : "::");
3090                     len += morelen;
3091                 }
3092
3093                 if (PL_expect == XOPERATOR) {
3094                     if (PL_bufptr == PL_linestart) {
3095                         PL_curcop->cop_line--;
3096                         warner(WARN_SEMICOLON, PL_warn_nosemi);
3097                         PL_curcop->cop_line++;
3098                     }
3099                     else
3100                         no_op("Bareword",s);
3101                 }
3102
3103                 /* Look for a subroutine with this name in current package,
3104                    unless name is "Foo::", in which case Foo is a bearword
3105                    (and a package name). */
3106
3107                 if (len > 2 &&
3108                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3109                 {
3110                     if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3111                         warner(WARN_UNSAFE,
3112                             "Bareword \"%s\" refers to nonexistent package",
3113                              PL_tokenbuf);
3114                     len -= 2;
3115                     PL_tokenbuf[len] = '\0';
3116                     gv = Nullgv;
3117                     gvp = 0;
3118                 }
3119                 else {
3120                     len = 0;
3121                     if (!gv)
3122                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3123                 }
3124
3125                 /* if we saw a global override before, get the right name */
3126
3127                 if (gvp) {
3128                     sv = newSVpv("CORE::GLOBAL::",14);
3129                     sv_catpv(sv,PL_tokenbuf);
3130                 }
3131                 else
3132                     sv = newSVpv(PL_tokenbuf,0);
3133
3134                 /* Presume this is going to be a bareword of some sort. */
3135
3136                 CLINE;
3137                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3138                 yylval.opval->op_private = OPpCONST_BARE;
3139
3140                 /* And if "Foo::", then that's what it certainly is. */
3141
3142                 if (len)
3143                     goto safe_bareword;
3144
3145                 /* See if it's the indirect object for a list operator. */
3146
3147                 if (PL_oldoldbufptr &&
3148                     PL_oldoldbufptr < PL_bufptr &&
3149                     (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3150                     /* NO SKIPSPACE BEFORE HERE! */
3151                     (PL_expect == XREF
3152                      || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3153                      || (PL_last_lop_op == OP_ENTERSUB
3154                          && PL_last_proto
3155                          && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3156                 {
3157                     bool immediate_paren = *s == '(';
3158
3159                     /* (Now we can afford to cross potential line boundary.) */
3160                     s = skipspace(s);
3161
3162                     /* Two barewords in a row may indicate method call. */
3163
3164                     if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3165                         return tmp;
3166
3167                     /* If not a declared subroutine, it's an indirect object. */
3168                     /* (But it's an indir obj regardless for sort.) */
3169
3170                     if ((PL_last_lop_op == OP_SORT ||
3171                          (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3172                         (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3173                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3174                         goto bareword;
3175                     }
3176                 }
3177
3178                 /* If followed by a paren, it's certainly a subroutine. */
3179
3180                 PL_expect = XOPERATOR;
3181                 s = skipspace(s);
3182                 if (*s == '(') {
3183                     CLINE;
3184                     if (gv && GvCVu(gv)) {
3185                         CV *cv;
3186                         if ((cv = GvCV(gv)) && SvPOK(cv))
3187                             PL_last_proto = SvPV((SV*)cv, n_a);
3188                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3189                         if (*d == ')' && (sv = cv_const_sv(cv))) {
3190                             s = d + 1;
3191                             goto its_constant;
3192                         }
3193                     }
3194                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3195                     PL_expect = XOPERATOR;
3196                     force_next(WORD);
3197                     yylval.ival = 0;
3198                     PL_last_lop_op = OP_ENTERSUB;
3199                     TOKEN('&');
3200                 }
3201
3202                 /* If followed by var or block, call it a method (unless sub) */
3203
3204                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3205                     PL_last_lop = PL_oldbufptr;
3206                     PL_last_lop_op = OP_METHOD;
3207                     PREBLOCK(METHOD);
3208                 }
3209
3210                 /* If followed by a bareword, see if it looks like indir obj. */
3211
3212                 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3213                     return tmp;
3214
3215                 /* Not a method, so call it a subroutine (if defined) */
3216
3217                 if (gv && GvCVu(gv)) {
3218                     CV* cv;
3219                     if (lastchar == '-')
3220                         warn("Ambiguous use of -%s resolved as -&%s()",
3221                                 PL_tokenbuf, PL_tokenbuf);
3222                     PL_last_lop = PL_oldbufptr;
3223                     PL_last_lop_op = OP_ENTERSUB;
3224                     /* Check for a constant sub */
3225                     cv = GvCV(gv);
3226                     if ((sv = cv_const_sv(cv))) {
3227                   its_constant:
3228                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3229                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3230                         yylval.opval->op_private = 0;
3231                         TOKEN(WORD);
3232                     }
3233
3234                     /* Resolve to GV now. */
3235                     op_free(yylval.opval);
3236                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3237                     PL_last_lop_op = OP_ENTERSUB;
3238                     /* Is there a prototype? */
3239                     if (SvPOK(cv)) {
3240                         STRLEN len;
3241                         PL_last_proto = SvPV((SV*)cv, len);
3242                         if (!len)
3243                             TERM(FUNC0SUB);
3244                         if (strEQ(PL_last_proto, "$"))
3245                             OPERATOR(UNIOPSUB);
3246                         if (*PL_last_proto == '&' && *s == '{') {
3247                             sv_setpv(PL_subname,"__ANON__");
3248                             PREBLOCK(LSTOPSUB);
3249                         }
3250                     } else
3251                         PL_last_proto = NULL;
3252                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3253                     PL_expect = XTERM;
3254                     force_next(WORD);
3255                     TOKEN(NOAMP);
3256                 }
3257
3258                 if (PL_hints & HINT_STRICT_SUBS &&
3259                     lastchar != '-' &&
3260                     strnNE(s,"->",2) &&
3261                     PL_last_lop_op != OP_TRUNCATE &&  /* S/F prototype in opcode.pl */
3262                     PL_last_lop_op != OP_ACCEPT &&
3263                     PL_last_lop_op != OP_PIPE_OP &&
3264                     PL_last_lop_op != OP_SOCKPAIR &&
3265                     !(PL_last_lop_op == OP_ENTERSUB
3266                          && PL_last_proto
3267                          && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3268                 {
3269                     warn(
3270                      "Bareword \"%s\" not allowed while \"strict subs\" in use",
3271                         PL_tokenbuf);
3272                     ++PL_error_count;
3273                 }
3274
3275                 /* Call it a bare word */
3276
3277             bareword:
3278                 if (ckWARN(WARN_RESERVED)) {
3279                     if (lastchar != '-') {
3280                         for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3281                         if (!*d)
3282                             warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
3283                     }
3284                 }
3285
3286             safe_bareword:
3287                 if (lastchar && strchr("*%&", lastchar)) {
3288                     warn("Operator or semicolon missing before %c%s",
3289                         lastchar, PL_tokenbuf);
3290                     warn("Ambiguous use of %c resolved as operator %c",
3291                         lastchar, lastchar);
3292                 }
3293                 TOKEN(WORD);
3294             }
3295
3296         case KEY___FILE__:
3297             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3298                                         newSVsv(GvSV(PL_curcop->cop_filegv)));
3299             TERM(THING);
3300
3301         case KEY___LINE__:
3302             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3303                                     newSVpvf("%ld", (long)PL_curcop->cop_line));
3304             TERM(THING);
3305
3306         case KEY___PACKAGE__:
3307             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3308                                         (PL_curstash
3309                                          ? newSVsv(PL_curstname)
3310                                          : &PL_sv_undef));
3311             TERM(THING);
3312
3313         case KEY___DATA__:
3314         case KEY___END__: {
3315             GV *gv;
3316
3317             /*SUPPRESS 560*/
3318             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3319                 char *pname = "main";
3320                 if (PL_tokenbuf[2] == 'D')
3321                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3322                 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3323                 GvMULTI_on(gv);
3324                 if (!GvIO(gv))
3325                     GvIOp(gv) = newIO();
3326                 IoIFP(GvIOp(gv)) = PL_rsfp;
3327 #if defined(HAS_FCNTL) && defined(F_SETFD)
3328                 {
3329                     int fd = PerlIO_fileno(PL_rsfp);
3330                     fcntl(fd,F_SETFD,fd >= 3);
3331                 }
3332 #endif
3333                 /* Mark this internal pseudo-handle as clean */
3334                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3335                 if (PL_preprocess)
3336                     IoTYPE(GvIOp(gv)) = '|';
3337                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3338                     IoTYPE(GvIOp(gv)) = '-';
3339                 else
3340                     IoTYPE(GvIOp(gv)) = '<';
3341                 PL_rsfp = Nullfp;
3342             }
3343             goto fake_eof;
3344         }
3345
3346         case KEY_AUTOLOAD:
3347         case KEY_DESTROY:
3348         case KEY_BEGIN:
3349         case KEY_END:
3350         case KEY_INIT:
3351             if (PL_expect == XSTATE) {
3352                 s = PL_bufptr;
3353                 goto really_sub;
3354             }
3355             goto just_a_word;
3356
3357         case KEY_CORE:
3358             if (*s == ':' && s[1] == ':') {
3359                 s += 2;
3360                 d = s;
3361                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3362                 tmp = keyword(PL_tokenbuf, len);
3363                 if (tmp < 0)
3364                     tmp = -tmp;
3365                 goto reserved_word;
3366             }
3367             goto just_a_word;
3368
3369         case KEY_abs:
3370             UNI(OP_ABS);
3371
3372         case KEY_alarm:
3373             UNI(OP_ALARM);
3374
3375         case KEY_accept:
3376             LOP(OP_ACCEPT,XTERM);
3377
3378         case KEY_and:
3379             OPERATOR(ANDOP);
3380
3381         case KEY_atan2:
3382             LOP(OP_ATAN2,XTERM);
3383
3384         case KEY_bind:
3385             LOP(OP_BIND,XTERM);
3386
3387         case KEY_binmode:
3388             UNI(OP_BINMODE);
3389
3390         case KEY_bless:
3391             LOP(OP_BLESS,XTERM);
3392
3393         case KEY_chop:
3394             UNI(OP_CHOP);
3395
3396         case KEY_continue:
3397             PREBLOCK(CONTINUE);
3398
3399         case KEY_chdir:
3400             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3401             UNI(OP_CHDIR);
3402
3403         case KEY_close:
3404             UNI(OP_CLOSE);
3405
3406         case KEY_closedir:
3407             UNI(OP_CLOSEDIR);
3408
3409         case KEY_cmp:
3410             Eop(OP_SCMP);
3411
3412         case KEY_caller:
3413             UNI(OP_CALLER);
3414
3415         case KEY_crypt:
3416 #ifdef FCRYPT
3417             if (!PL_cryptseen++)
3418                 init_des();
3419 #endif
3420             LOP(OP_CRYPT,XTERM);
3421
3422         case KEY_chmod:
3423             if (ckWARN(WARN_OCTAL)) {
3424                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3425                 if (*d != '0' && isDIGIT(*d))
3426                     yywarn("chmod: mode argument is missing initial 0");
3427             }
3428             LOP(OP_CHMOD,XTERM);
3429
3430         case KEY_chown:
3431             LOP(OP_CHOWN,XTERM);
3432
3433         case KEY_connect:
3434             LOP(OP_CONNECT,XTERM);
3435
3436         case KEY_chr:
3437             UNI(OP_CHR);
3438
3439         case KEY_cos:
3440             UNI(OP_COS);
3441
3442         case KEY_chroot:
3443             UNI(OP_CHROOT);
3444
3445         case KEY_do:
3446             s = skipspace(s);
3447             if (*s == '{')
3448                 PRETERMBLOCK(DO);
3449             if (*s != '\'')
3450                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3451             OPERATOR(DO);
3452
3453         case KEY_die:
3454             PL_hints |= HINT_BLOCK_SCOPE;
3455             LOP(OP_DIE,XTERM);
3456
3457         case KEY_defined:
3458             UNI(OP_DEFINED);
3459
3460         case KEY_delete:
3461             UNI(OP_DELETE);
3462
3463         case KEY_dbmopen:
3464             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3465             LOP(OP_DBMOPEN,XTERM);
3466
3467         case KEY_dbmclose:
3468             UNI(OP_DBMCLOSE);
3469
3470         case KEY_dump:
3471             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3472             LOOPX(OP_DUMP);
3473
3474         case KEY_else:
3475             PREBLOCK(ELSE);
3476
3477         case KEY_elsif:
3478             yylval.ival = PL_curcop->cop_line;
3479             OPERATOR(ELSIF);
3480
3481         case KEY_eq:
3482             Eop(OP_SEQ);
3483
3484         case KEY_exists:
3485             UNI(OP_EXISTS);
3486
3487         case KEY_exit:
3488             UNI(OP_EXIT);
3489
3490         case KEY_eval:
3491             s = skipspace(s);
3492             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3493             UNIBRACK(OP_ENTEREVAL);
3494
3495         case KEY_eof:
3496             UNI(OP_EOF);
3497
3498         case KEY_exp:
3499             UNI(OP_EXP);
3500
3501         case KEY_each:
3502             UNI(OP_EACH);
3503
3504         case KEY_exec:
3505             set_csh();
3506             LOP(OP_EXEC,XREF);
3507
3508         case KEY_endhostent:
3509             FUN0(OP_EHOSTENT);
3510
3511         case KEY_endnetent:
3512             FUN0(OP_ENETENT);
3513
3514         case KEY_endservent:
3515             FUN0(OP_ESERVENT);
3516
3517         case KEY_endprotoent:
3518             FUN0(OP_EPROTOENT);
3519
3520         case KEY_endpwent:
3521             FUN0(OP_EPWENT);
3522
3523         case KEY_endgrent:
3524             FUN0(OP_EGRENT);
3525
3526         case KEY_for:
3527         case KEY_foreach:
3528             yylval.ival = PL_curcop->cop_line;
3529             s = skipspace(s);
3530             if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3531                 char *p = s;
3532                 if ((PL_bufend - p) >= 3 &&
3533                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3534                     p += 2;
3535                 p = skipspace(p);
3536                 if (isIDFIRST_lazy(p))
3537                     croak("Missing $ on loop variable");
3538             }
3539             OPERATOR(FOR);
3540
3541         case KEY_formline:
3542             LOP(OP_FORMLINE,XTERM);
3543
3544         case KEY_fork:
3545             FUN0(OP_FORK);
3546
3547         case KEY_fcntl:
3548             LOP(OP_FCNTL,XTERM);
3549
3550         case KEY_fileno:
3551             UNI(OP_FILENO);
3552
3553         case KEY_flock:
3554             LOP(OP_FLOCK,XTERM);
3555
3556         case KEY_gt:
3557             Rop(OP_SGT);
3558
3559         case KEY_ge:
3560             Rop(OP_SGE);
3561
3562         case KEY_grep:
3563             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3564
3565         case KEY_goto:
3566             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3567             LOOPX(OP_GOTO);
3568
3569         case KEY_gmtime:
3570             UNI(OP_GMTIME);
3571
3572         case KEY_getc:
3573             UNI(OP_GETC);
3574
3575         case KEY_getppid:
3576             FUN0(OP_GETPPID);
3577
3578         case KEY_getpgrp:
3579             UNI(OP_GETPGRP);
3580
3581         case KEY_getpriority:
3582             LOP(OP_GETPRIORITY,XTERM);
3583
3584         case KEY_getprotobyname:
3585             UNI(OP_GPBYNAME);
3586
3587         case KEY_getprotobynumber:
3588             LOP(OP_GPBYNUMBER,XTERM);
3589
3590         case KEY_getprotoent:
3591             FUN0(OP_GPROTOENT);
3592
3593         case KEY_getpwent:
3594             FUN0(OP_GPWENT);
3595
3596         case KEY_getpwnam:
3597             UNI(OP_GPWNAM);
3598
3599         case KEY_getpwuid:
3600             UNI(OP_GPWUID);
3601
3602         case KEY_getpeername:
3603             UNI(OP_GETPEERNAME);
3604
3605         case KEY_gethostbyname:
3606             UNI(OP_GHBYNAME);
3607
3608         case KEY_gethostbyaddr:
3609             LOP(OP_GHBYADDR,XTERM);
3610
3611         case KEY_gethostent:
3612             FUN0(OP_GHOSTENT);
3613
3614         case KEY_getnetbyname:
3615             UNI(OP_GNBYNAME);
3616
3617         case KEY_getnetbyaddr:
3618             LOP(OP_GNBYADDR,XTERM);
3619
3620         case KEY_getnetent:
3621             FUN0(OP_GNETENT);
3622
3623         case KEY_getservbyname:
3624             LOP(OP_GSBYNAME,XTERM);
3625
3626         case KEY_getservbyport:
3627             LOP(OP_GSBYPORT,XTERM);
3628
3629         case KEY_getservent:
3630             FUN0(OP_GSERVENT);
3631
3632         case KEY_getsockname:
3633             UNI(OP_GETSOCKNAME);
3634
3635         case KEY_getsockopt:
3636             LOP(OP_GSOCKOPT,XTERM);
3637
3638         case KEY_getgrent:
3639             FUN0(OP_GGRENT);
3640
3641         case KEY_getgrnam:
3642             UNI(OP_GGRNAM);
3643
3644         case KEY_getgrgid:
3645             UNI(OP_GGRGID);
3646
3647         case KEY_getlogin:
3648             FUN0(OP_GETLOGIN);
3649
3650         case KEY_glob:
3651             set_csh();
3652             LOP(OP_GLOB,XTERM);
3653
3654         case KEY_hex:
3655             UNI(OP_HEX);
3656
3657         case KEY_if:
3658             yylval.ival = PL_curcop->cop_line;
3659             OPERATOR(IF);
3660
3661         case KEY_index:
3662             LOP(OP_INDEX,XTERM);
3663
3664         case KEY_int:
3665             UNI(OP_INT);
3666
3667         case KEY_ioctl:
3668             LOP(OP_IOCTL,XTERM);
3669
3670         case KEY_join:
3671             LOP(OP_JOIN,XTERM);
3672
3673         case KEY_keys:
3674             UNI(OP_KEYS);
3675
3676         case KEY_kill:
3677             LOP(OP_KILL,XTERM);
3678
3679         case KEY_last:
3680             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3681             LOOPX(OP_LAST);
3682
3683         case KEY_lc:
3684             UNI(OP_LC);
3685
3686         case KEY_lcfirst:
3687             UNI(OP_LCFIRST);
3688
3689         case KEY_local:
3690             OPERATOR(LOCAL);
3691
3692         case KEY_length:
3693             UNI(OP_LENGTH);
3694
3695         case KEY_lt:
3696             Rop(OP_SLT);
3697
3698         case KEY_le:
3699             Rop(OP_SLE);
3700
3701         case KEY_localtime:
3702             UNI(OP_LOCALTIME);
3703
3704         case KEY_log:
3705             UNI(OP_LOG);
3706
3707         case KEY_link:
3708             LOP(OP_LINK,XTERM);
3709
3710         case KEY_listen:
3711             LOP(OP_LISTEN,XTERM);
3712
3713         case KEY_lock:
3714             UNI(OP_LOCK);
3715
3716         case KEY_lstat:
3717             UNI(OP_LSTAT);
3718
3719         case KEY_m:
3720             s = scan_pat(s,OP_MATCH);
3721             TERM(sublex_start());
3722
3723         case KEY_map:
3724             LOP(OP_MAPSTART, XREF);
3725
3726         case KEY_mkdir:
3727             LOP(OP_MKDIR,XTERM);
3728
3729         case KEY_msgctl:
3730             LOP(OP_MSGCTL,XTERM);
3731
3732         case KEY_msgget:
3733             LOP(OP_MSGGET,XTERM);
3734
3735         case KEY_msgrcv:
3736             LOP(OP_MSGRCV,XTERM);
3737
3738         case KEY_msgsnd:
3739             LOP(OP_MSGSND,XTERM);
3740
3741         case KEY_my:
3742             PL_in_my = TRUE;
3743             s = skipspace(s);
3744             if (isIDFIRST_lazy(s)) {
3745                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3746                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3747                 if (!PL_in_my_stash) {
3748                     char tmpbuf[1024];
3749                     PL_bufptr = s;
3750                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3751                     yyerror(tmpbuf);
3752                 }
3753             }
3754             OPERATOR(MY);
3755
3756         case KEY_next:
3757             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3758             LOOPX(OP_NEXT);
3759
3760         case KEY_ne:
3761             Eop(OP_SNE);
3762
3763         case KEY_no:
3764             if (PL_expect != XSTATE)
3765                 yyerror("\"no\" not allowed in expression");
3766             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3767             s = force_version(s);
3768             yylval.ival = 0;
3769             OPERATOR(USE);
3770
3771         case KEY_not:
3772             OPERATOR(NOTOP);
3773
3774         case KEY_open:
3775             s = skipspace(s);
3776             if (isIDFIRST_lazy(s)) {
3777                 char *t;
3778                 for (d = s; isALNUM_lazy(d); d++) ;
3779                 t = skipspace(d);
3780                 if (strchr("|&*+-=!?:.", *t))
3781                     warn("Precedence problem: open %.*s should be open(%.*s)",
3782                         d-s,s, d-s,s);
3783             }
3784             LOP(OP_OPEN,XTERM);
3785
3786         case KEY_or:
3787             yylval.ival = OP_OR;
3788             OPERATOR(OROP);
3789
3790         case KEY_ord:
3791             UNI(OP_ORD);
3792
3793         case KEY_oct:
3794             UNI(OP_OCT);
3795
3796         case KEY_opendir:
3797             LOP(OP_OPEN_DIR,XTERM);
3798
3799         case KEY_print:
3800             checkcomma(s,PL_tokenbuf,"filehandle");
3801             LOP(OP_PRINT,XREF);
3802
3803         case KEY_printf:
3804             checkcomma(s,PL_tokenbuf,"filehandle");
3805             LOP(OP_PRTF,XREF);
3806
3807         case KEY_prototype:
3808             UNI(OP_PROTOTYPE);
3809
3810         case KEY_push:
3811             LOP(OP_PUSH,XTERM);
3812
3813         case KEY_pop:
3814             UNI(OP_POP);
3815
3816         case KEY_pos:
3817             UNI(OP_POS);
3818
3819         case KEY_pack:
3820             LOP(OP_PACK,XTERM);
3821
3822         case KEY_package:
3823             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3824             OPERATOR(PACKAGE);
3825
3826         case KEY_pipe:
3827             LOP(OP_PIPE_OP,XTERM);
3828
3829         case KEY_q:
3830             s = scan_str(s);
3831             if (!s)
3832                 missingterm((char*)0);
3833             yylval.ival = OP_CONST;
3834             TERM(sublex_start());
3835
3836         case KEY_quotemeta:
3837             UNI(OP_QUOTEMETA);
3838
3839         case KEY_qw:
3840             s = scan_str(s);
3841             if (!s)
3842                 missingterm((char*)0);
3843             force_next(')');
3844             if (SvCUR(PL_lex_stuff)) {
3845                 OP *words = Nullop;
3846                 int warned = 0;
3847                 d = SvPV_force(PL_lex_stuff, len);
3848                 while (len) {
3849                     for (; isSPACE(*d) && len; --len, ++d) ;
3850                     if (len) {
3851                         char *b = d;
3852                         if (!warned && ckWARN(WARN_SYNTAX)) {
3853                             for (; !isSPACE(*d) && len; --len, ++d) {
3854                                 if (*d == ',') {
3855                                     warner(WARN_SYNTAX,
3856                                         "Possible attempt to separate words with commas");
3857                                     ++warned;
3858                                 }
3859                                 else if (*d == '#') {
3860                                     warner(WARN_SYNTAX,
3861                                         "Possible attempt to put comments in qw() list");
3862                                     ++warned;
3863                                 }
3864                             }
3865                         }
3866                         else {
3867                             for (; !isSPACE(*d) && len; --len, ++d) ;
3868                         }
3869                         words = append_elem(OP_LIST, words,
3870                                             newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
3871                     }
3872                 }
3873                 if (words) {
3874                     PL_nextval[PL_nexttoke].opval = words;
3875                     force_next(THING);
3876                 }
3877             }
3878             if (PL_lex_stuff)
3879                 SvREFCNT_dec(PL_lex_stuff);
3880             PL_lex_stuff = Nullsv;
3881             PL_expect = XTERM;
3882             TOKEN('(');
3883
3884         case KEY_qq:
3885             s = scan_str(s);
3886             if (!s)
3887                 missingterm((char*)0);
3888             yylval.ival = OP_STRINGIFY;
3889             if (SvIVX(PL_lex_stuff) == '\'')
3890                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
3891             TERM(sublex_start());
3892
3893         case KEY_qr:
3894             s = scan_pat(s,OP_QR);
3895             TERM(sublex_start());
3896
3897         case KEY_qx:
3898             s = scan_str(s);
3899             if (!s)
3900                 missingterm((char*)0);
3901             yylval.ival = OP_BACKTICK;
3902             set_csh();
3903             TERM(sublex_start());
3904
3905         case KEY_return:
3906             OLDLOP(OP_RETURN);
3907
3908         case KEY_require:
3909             *PL_tokenbuf = '\0';
3910             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3911             if (isIDFIRST_lazy(PL_tokenbuf))
3912                 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3913             else if (*s == '<')
3914                 yyerror("<> should be quotes");
3915             UNI(OP_REQUIRE);
3916
3917         case KEY_reset:
3918             UNI(OP_RESET);
3919
3920         case KEY_redo:
3921             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3922             LOOPX(OP_REDO);
3923
3924         case KEY_rename:
3925             LOP(OP_RENAME,XTERM);
3926
3927         case KEY_rand:
3928             UNI(OP_RAND);
3929
3930         case KEY_rmdir:
3931             UNI(OP_RMDIR);
3932
3933         case KEY_rindex:
3934             LOP(OP_RINDEX,XTERM);
3935
3936         case KEY_read:
3937             LOP(OP_READ,XTERM);
3938
3939         case KEY_readdir:
3940             UNI(OP_READDIR);
3941
3942         case KEY_readline:
3943             set_csh();
3944             UNI(OP_READLINE);
3945
3946         case KEY_readpipe:
3947             set_csh();
3948             UNI(OP_BACKTICK);
3949
3950         case KEY_rewinddir:
3951             UNI(OP_REWINDDIR);
3952
3953         case KEY_recv:
3954             LOP(OP_RECV,XTERM);
3955
3956         case KEY_reverse:
3957             LOP(OP_REVERSE,XTERM);
3958
3959         case KEY_readlink:
3960             UNI(OP_READLINK);
3961
3962         case KEY_ref:
3963             UNI(OP_REF);
3964
3965         case KEY_s:
3966             s = scan_subst(s);
3967             if (yylval.opval)
3968                 TERM(sublex_start());
3969             else
3970                 TOKEN(1);       /* force error */
3971
3972         case KEY_chomp:
3973             UNI(OP_CHOMP);
3974
3975         case KEY_scalar:
3976             UNI(OP_SCALAR);
3977
3978         case KEY_select:
3979             LOP(OP_SELECT,XTERM);
3980
3981         case KEY_seek:
3982             LOP(OP_SEEK,XTERM);
3983
3984         case KEY_semctl:
3985             LOP(OP_SEMCTL,XTERM);
3986
3987         case KEY_semget:
3988             LOP(OP_SEMGET,XTERM);
3989
3990         case KEY_semop:
3991             LOP(OP_SEMOP,XTERM);
3992
3993         case KEY_send:
3994             LOP(OP_SEND,XTERM);
3995
3996         case KEY_setpgrp:
3997             LOP(OP_SETPGRP,XTERM);
3998
3999         case KEY_setpriority:
4000             LOP(OP_SETPRIORITY,XTERM);
4001
4002         case KEY_sethostent:
4003             UNI(OP_SHOSTENT);
4004
4005         case KEY_setnetent:
4006             UNI(OP_SNETENT);
4007
4008         case KEY_setservent:
4009             UNI(OP_SSERVENT);
4010
4011         case KEY_setprotoent:
4012             UNI(OP_SPROTOENT);
4013
4014         case KEY_setpwent:
4015             FUN0(OP_SPWENT);
4016
4017         case KEY_setgrent:
4018             FUN0(OP_SGRENT);
4019
4020         case KEY_seekdir:
4021             LOP(OP_SEEKDIR,XTERM);
4022
4023         case KEY_setsockopt:
4024             LOP(OP_SSOCKOPT,XTERM);
4025
4026         case KEY_shift:
4027             UNI(OP_SHIFT);
4028
4029         case KEY_shmctl:
4030             LOP(OP_SHMCTL,XTERM);
4031
4032         case KEY_shmget:
4033             LOP(OP_SHMGET,XTERM);
4034
4035         case KEY_shmread:
4036             LOP(OP_SHMREAD,XTERM);
4037
4038         case KEY_shmwrite:
4039             LOP(OP_SHMWRITE,XTERM);
4040
4041         case KEY_shutdown:
4042             LOP(OP_SHUTDOWN,XTERM);
4043
4044         case KEY_sin:
4045             UNI(OP_SIN);
4046
4047         case KEY_sleep:
4048             UNI(OP_SLEEP);
4049
4050         case KEY_socket:
4051             LOP(OP_SOCKET,XTERM);
4052
4053         case KEY_socketpair:
4054             LOP(OP_SOCKPAIR,XTERM);
4055
4056         case KEY_sort:
4057             checkcomma(s,PL_tokenbuf,"subroutine name");
4058             s = skipspace(s);
4059             if (*s == ';' || *s == ')')         /* probably a close */
4060                 croak("sort is now a reserved word");
4061             PL_expect = XTERM;
4062             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4063             LOP(OP_SORT,XREF);
4064
4065         case KEY_split:
4066             LOP(OP_SPLIT,XTERM);
4067
4068         case KEY_sprintf:
4069             LOP(OP_SPRINTF,XTERM);
4070
4071         case KEY_splice:
4072             LOP(OP_SPLICE,XTERM);
4073
4074         case KEY_sqrt:
4075             UNI(OP_SQRT);
4076
4077         case KEY_srand:
4078             UNI(OP_SRAND);
4079
4080         case KEY_stat:
4081             UNI(OP_STAT);
4082
4083         case KEY_study:
4084             PL_sawstudy++;
4085             UNI(OP_STUDY);
4086
4087         case KEY_substr:
4088             LOP(OP_SUBSTR,XTERM);
4089
4090         case KEY_format:
4091         case KEY_sub:
4092           really_sub:
4093             s = skipspace(s);
4094
4095             if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4096                 char tmpbuf[sizeof PL_tokenbuf];
4097                 PL_expect = XBLOCK;
4098                 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4099                 if (strchr(tmpbuf, ':'))
4100                     sv_setpv(PL_subname, tmpbuf);
4101                 else {
4102                     sv_setsv(PL_subname,PL_curstname);
4103                     sv_catpvn(PL_subname,"::",2);
4104                     sv_catpvn(PL_subname,tmpbuf,len);
4105                 }
4106                 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4107                 s = skipspace(s);
4108             }
4109             else {
4110                 PL_expect = XTERMBLOCK;
4111                 sv_setpv(PL_subname,"?");
4112             }
4113
4114             if (tmp == KEY_format) {
4115                 s = skipspace(s);
4116                 if (*s == '=')
4117                     PL_lex_formbrack = PL_lex_brackets + 1;
4118                 OPERATOR(FORMAT);
4119             }
4120
4121             /* Look for a prototype */
4122             if (*s == '(') {
4123                 char *p;
4124
4125                 s = scan_str(s);
4126                 if (!s) {
4127                     if (PL_lex_stuff)
4128                         SvREFCNT_dec(PL_lex_stuff);
4129                     PL_lex_stuff = Nullsv;
4130                     croak("Prototype not terminated");
4131                 }
4132                 /* strip spaces */
4133                 d = SvPVX(PL_lex_stuff);
4134                 tmp = 0;
4135                 for (p = d; *p; ++p) {
4136                     if (!isSPACE(*p))
4137                         d[tmp++] = *p;
4138                 }
4139                 d[tmp] = '\0';
4140                 SvCUR(PL_lex_stuff) = tmp;
4141
4142                 PL_nexttoke++;
4143                 PL_nextval[1] = PL_nextval[0];
4144                 PL_nexttype[1] = PL_nexttype[0];
4145                 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4146                 PL_nexttype[0] = THING;
4147                 if (PL_nexttoke == 1) {
4148                     PL_lex_defer = PL_lex_state;
4149                     PL_lex_expect = PL_expect;
4150                     PL_lex_state = LEX_KNOWNEXT;
4151                 }
4152                 PL_lex_stuff = Nullsv;
4153             }
4154
4155             if (*SvPV(PL_subname,n_a) == '?') {
4156                 sv_setpv(PL_subname,"__ANON__");
4157                 TOKEN(ANONSUB);
4158             }
4159             PREBLOCK(SUB);
4160
4161         case KEY_system:
4162             set_csh();
4163             LOP(OP_SYSTEM,XREF);
4164
4165         case KEY_symlink:
4166             LOP(OP_SYMLINK,XTERM);
4167
4168         case KEY_syscall:
4169             LOP(OP_SYSCALL,XTERM);
4170
4171         case KEY_sysopen:
4172             LOP(OP_SYSOPEN,XTERM);
4173
4174         case KEY_sysseek:
4175             LOP(OP_SYSSEEK,XTERM);
4176
4177         case KEY_sysread:
4178             LOP(OP_SYSREAD,XTERM);
4179
4180         case KEY_syswrite:
4181             LOP(OP_SYSWRITE,XTERM);
4182
4183         case KEY_tr:
4184             s = scan_trans(s);
4185             TERM(sublex_start());
4186
4187         case KEY_tell:
4188             UNI(OP_TELL);
4189
4190         case KEY_telldir:
4191             UNI(OP_TELLDIR);
4192
4193         case KEY_tie:
4194             LOP(OP_TIE,XTERM);
4195
4196         case KEY_tied:
4197             UNI(OP_TIED);
4198
4199         case KEY_time:
4200             FUN0(OP_TIME);
4201
4202         case KEY_times:
4203             FUN0(OP_TMS);
4204
4205         case KEY_truncate:
4206             LOP(OP_TRUNCATE,XTERM);
4207
4208         case KEY_uc:
4209             UNI(OP_UC);
4210
4211         case KEY_ucfirst:
4212             UNI(OP_UCFIRST);
4213
4214         case KEY_untie:
4215             UNI(OP_UNTIE);
4216
4217         case KEY_until:
4218             yylval.ival = PL_curcop->cop_line;
4219             OPERATOR(UNTIL);
4220
4221         case KEY_unless:
4222             yylval.ival = PL_curcop->cop_line;
4223             OPERATOR(UNLESS);
4224
4225         case KEY_unlink:
4226             LOP(OP_UNLINK,XTERM);
4227
4228         case KEY_undef:
4229             UNI(OP_UNDEF);
4230
4231         case KEY_unpack:
4232             LOP(OP_UNPACK,XTERM);
4233
4234         case KEY_utime:
4235             LOP(OP_UTIME,XTERM);
4236
4237         case KEY_umask:
4238             if (ckWARN(WARN_OCTAL)) {
4239                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4240                 if (*d != '0' && isDIGIT(*d))
4241                     yywarn("umask: argument is missing initial 0");
4242             }
4243             UNI(OP_UMASK);
4244
4245         case KEY_unshift:
4246             LOP(OP_UNSHIFT,XTERM);
4247
4248         case KEY_use:
4249             if (PL_expect != XSTATE)
4250                 yyerror("\"use\" not allowed in expression");
4251             s = skipspace(s);
4252             if(isDIGIT(*s)) {
4253                 s = force_version(s);
4254                 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4255                     PL_nextval[PL_nexttoke].opval = Nullop;
4256                     force_next(WORD);
4257                 }
4258             }
4259             else {
4260                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4261                 s = force_version(s);
4262             }
4263             yylval.ival = 1;
4264             OPERATOR(USE);
4265
4266         case KEY_values:
4267             UNI(OP_VALUES);
4268
4269         case KEY_vec:
4270             PL_sawvec = TRUE;
4271             LOP(OP_VEC,XTERM);
4272
4273         case KEY_while:
4274             yylval.ival = PL_curcop->cop_line;
4275             OPERATOR(WHILE);
4276
4277         case KEY_warn:
4278             PL_hints |= HINT_BLOCK_SCOPE;
4279             LOP(OP_WARN,XTERM);
4280
4281         case KEY_wait:
4282             FUN0(OP_WAIT);
4283
4284         case KEY_waitpid:
4285             LOP(OP_WAITPID,XTERM);
4286
4287         case KEY_wantarray:
4288             FUN0(OP_WANTARRAY);
4289
4290         case KEY_write:
4291 #ifdef EBCDIC
4292         {
4293             static char ctl_l[2];
4294
4295             if (ctl_l[0] == '\0')
4296                 ctl_l[0] = toCTRL('L');
4297             gv_fetchpv(ctl_l,TRUE, SVt_PV);
4298         }
4299 #else
4300             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4301 #endif
4302             UNI(OP_ENTERWRITE);
4303
4304         case KEY_x:
4305             if (PL_expect == XOPERATOR)
4306                 Mop(OP_REPEAT);
4307             check_uni();
4308             goto just_a_word;
4309
4310         case KEY_xor:
4311             yylval.ival = OP_XOR;
4312             OPERATOR(OROP);
4313
4314         case KEY_y:
4315             s = scan_trans(s);
4316             TERM(sublex_start());
4317         }
4318     }}
4319 }
4320
4321 I32
4322 keyword(register char *d, I32 len)
4323 {
4324     switch (*d) {
4325     case '_':
4326         if (d[1] == '_') {
4327             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4328             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4329             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4330             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4331             if (strEQ(d,"__END__"))             return KEY___END__;
4332         }
4333         break;
4334     case 'A':
4335         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4336         break;
4337     case 'a':
4338         switch (len) {
4339         case 3:
4340             if (strEQ(d,"and"))                 return -KEY_and;
4341             if (strEQ(d,"abs"))                 return -KEY_abs;
4342             break;
4343         case 5:
4344             if (strEQ(d,"alarm"))               return -KEY_alarm;
4345             if (strEQ(d,"atan2"))               return -KEY_atan2;
4346             break;
4347         case 6:
4348             if (strEQ(d,"accept"))              return -KEY_accept;
4349             break;
4350         }
4351         break;
4352     case 'B':
4353         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4354         break;
4355     case 'b':
4356         if (strEQ(d,"bless"))                   return -KEY_bless;
4357         if (strEQ(d,"bind"))                    return -KEY_bind;
4358         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4359         break;
4360     case 'C':
4361         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4362         break;
4363     case 'c':
4364         switch (len) {
4365         case 3:
4366             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4367             if (strEQ(d,"chr"))                 return -KEY_chr;
4368             if (strEQ(d,"cos"))                 return -KEY_cos;
4369             break;
4370         case 4:
4371             if (strEQ(d,"chop"))                return KEY_chop;
4372             break;
4373         case 5:
4374             if (strEQ(d,"close"))               return -KEY_close;
4375             if (strEQ(d,"chdir"))               return -KEY_chdir;
4376             if (strEQ(d,"chomp"))               return KEY_chomp;
4377             if (strEQ(d,"chmod"))               return -KEY_chmod;
4378             if (strEQ(d,"chown"))               return -KEY_chown;
4379             if (strEQ(d,"crypt"))               return -KEY_crypt;
4380             break;
4381         case 6:
4382             if (strEQ(d,"chroot"))              return -KEY_chroot;
4383             if (strEQ(d,"caller"))              return -KEY_caller;
4384             break;
4385         case 7:
4386             if (strEQ(d,"connect"))             return -KEY_connect;
4387             break;
4388         case 8:
4389             if (strEQ(d,"closedir"))            return -KEY_closedir;
4390             if (strEQ(d,"continue"))            return -KEY_continue;
4391             break;
4392         }
4393         break;
4394     case 'D':
4395         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4396         break;
4397     case 'd':
4398         switch (len) {
4399         case 2:
4400             if (strEQ(d,"do"))                  return KEY_do;
4401             break;
4402         case 3:
4403             if (strEQ(d,"die"))                 return -KEY_die;
4404             break;
4405         case 4:
4406             if (strEQ(d,"dump"))                return -KEY_dump;
4407             break;
4408         case 6:
4409             if (strEQ(d,"delete"))              return KEY_delete;
4410             break;
4411         case 7:
4412             if (strEQ(d,"defined"))             return KEY_defined;
4413             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
4414             break;
4415         case 8:
4416             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
4417             break;
4418         }
4419         break;
4420     case 'E':
4421         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
4422         if (strEQ(d,"END"))                     return KEY_END;
4423         break;
4424     case 'e':
4425         switch (len) {
4426         case 2:
4427             if (strEQ(d,"eq"))                  return -KEY_eq;
4428             break;
4429         case 3:
4430             if (strEQ(d,"eof"))                 return -KEY_eof;
4431             if (strEQ(d,"exp"))                 return -KEY_exp;
4432             break;
4433         case 4:
4434             if (strEQ(d,"else"))                return KEY_else;
4435             if (strEQ(d,"exit"))                return -KEY_exit;
4436             if (strEQ(d,"eval"))                return KEY_eval;
4437             if (strEQ(d,"exec"))                return -KEY_exec;
4438             if (strEQ(d,"each"))                return KEY_each;
4439             break;
4440         case 5:
4441             if (strEQ(d,"elsif"))               return KEY_elsif;
4442             break;
4443         case 6:
4444             if (strEQ(d,"exists"))              return KEY_exists;
4445             if (strEQ(d,"elseif")) warn("elseif should be elsif");
4446             break;
4447         case 8:
4448             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
4449             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
4450             break;
4451         case 9:
4452             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
4453             break;
4454         case 10:
4455             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
4456             if (strEQ(d,"endservent"))          return -KEY_endservent;
4457             break;
4458         case 11:
4459             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
4460             break;
4461         }
4462         break;
4463     case 'f':
4464         switch (len) {
4465         case 3:
4466             if (strEQ(d,"for"))                 return KEY_for;
4467             break;
4468         case 4:
4469             if (strEQ(d,"fork"))                return -KEY_fork;
4470             break;
4471         case 5:
4472             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
4473             if (strEQ(d,"flock"))               return -KEY_flock;
4474             break;
4475         case 6:
4476             if (strEQ(d,"format"))              return KEY_format;
4477             if (strEQ(d,"fileno"))              return -KEY_fileno;
4478             break;
4479         case 7:
4480             if (strEQ(d,"foreach"))             return KEY_foreach;
4481             break;
4482         case 8:
4483             if (strEQ(d,"formline"))            return -KEY_formline;
4484             break;
4485         }
4486         break;
4487     case 'G':
4488         if (len == 2) {
4489             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
4490             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
4491         }
4492         break;
4493     case 'g':
4494         if (strnEQ(d,"get",3)) {
4495             d += 3;
4496             if (*d == 'p') {
4497                 switch (len) {
4498                 case 7:
4499                     if (strEQ(d,"ppid"))        return -KEY_getppid;
4500                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
4501                     break;
4502                 case 8:
4503                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
4504                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
4505                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
4506                     break;
4507                 case 11:
4508                     if (strEQ(d,"peername"))    return -KEY_getpeername;
4509                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
4510                     if (strEQ(d,"priority"))    return -KEY_getpriority;
4511                     break;
4512                 case 14:
4513                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4514                     break;
4515                 case 16:
4516                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4517                     break;
4518                 }
4519             }
4520             else if (*d == 'h') {
4521                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
4522                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
4523                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
4524             }
4525             else if (*d == 'n') {
4526                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
4527                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
4528                 if (strEQ(d,"netent"))          return -KEY_getnetent;
4529             }
4530             else if (*d == 's') {
4531                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
4532                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
4533                 if (strEQ(d,"servent"))         return -KEY_getservent;
4534                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
4535                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
4536             }
4537             else if (*d == 'g') {
4538                 if (strEQ(d,"grent"))           return -KEY_getgrent;
4539                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
4540                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
4541             }
4542             else if (*d == 'l') {
4543                 if (strEQ(d,"login"))           return -KEY_getlogin;
4544             }
4545             else if (strEQ(d,"c"))              return -KEY_getc;
4546             break;
4547         }
4548         switch (len) {
4549         case 2:
4550             if (strEQ(d,"gt"))                  return -KEY_gt;
4551             if (strEQ(d,"ge"))                  return -KEY_ge;
4552             break;
4553         case 4:
4554             if (strEQ(d,"grep"))                return KEY_grep;
4555             if (strEQ(d,"goto"))                return KEY_goto;
4556             if (strEQ(d,"glob"))                return KEY_glob;
4557             break;
4558         case 6:
4559             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
4560             break;
4561         }
4562         break;
4563     case 'h':
4564         if (strEQ(d,"hex"))                     return -KEY_hex;
4565         break;
4566     case 'I':
4567         if (strEQ(d,"INIT"))                    return KEY_INIT;
4568         break;
4569     case 'i':
4570         switch (len) {
4571         case 2:
4572             if (strEQ(d,"if"))                  return KEY_if;
4573             break;
4574         case 3:
4575             if (strEQ(d,"int"))                 return -KEY_int;
4576             break;
4577         case 5:
4578             if (strEQ(d,"index"))               return -KEY_index;
4579             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
4580             break;
4581         }
4582         break;
4583     case 'j':
4584         if (strEQ(d,"join"))                    return -KEY_join;
4585         break;
4586     case 'k':
4587         if (len == 4) {
4588             if (strEQ(d,"keys"))                return KEY_keys;
4589             if (strEQ(d,"kill"))                return -KEY_kill;
4590         }
4591         break;
4592     case 'L':
4593         if (len == 2) {
4594             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
4595             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
4596         }
4597         break;
4598     case 'l':
4599         switch (len) {
4600         case 2:
4601             if (strEQ(d,"lt"))                  return -KEY_lt;
4602             if (strEQ(d,"le"))                  return -KEY_le;
4603             if (strEQ(d,"lc"))                  return -KEY_lc;
4604             break;
4605         case 3:
4606             if (strEQ(d,"log"))                 return -KEY_log;
4607             break;
4608         case 4:
4609             if (strEQ(d,"last"))                return KEY_last;
4610             if (strEQ(d,"link"))                return -KEY_link;
4611             if (strEQ(d,"lock"))                return -KEY_lock;
4612             break;
4613         case 5:
4614             if (strEQ(d,"local"))               return KEY_local;
4615             if (strEQ(d,"lstat"))               return -KEY_lstat;
4616             break;
4617         case 6:
4618             if (strEQ(d,"length"))              return -KEY_length;
4619             if (strEQ(d,"listen"))              return -KEY_listen;
4620             break;
4621         case 7:
4622             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
4623             break;
4624         case 9:
4625             if (strEQ(d,"localtime"))           return -KEY_localtime;
4626             break;
4627         }
4628         break;
4629     case 'm':
4630         switch (len) {
4631         case 1:                                 return KEY_m;
4632         case 2:
4633             if (strEQ(d,"my"))                  return KEY_my;
4634             break;
4635         case 3:
4636             if (strEQ(d,"map"))                 return KEY_map;
4637             break;
4638         case 5:
4639             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
4640             break;
4641         case 6:
4642             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
4643             if (strEQ(d,"msgget"))              return -KEY_msgget;
4644             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
4645             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
4646             break;
4647         }
4648         break;
4649     case 'N':
4650         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
4651         break;
4652     case 'n':
4653         if (strEQ(d,"next"))                    return KEY_next;
4654         if (strEQ(d,"ne"))                      return -KEY_ne;
4655         if (strEQ(d,"not"))                     return -KEY_not;
4656         if (strEQ(d,"no"))                      return KEY_no;
4657         break;
4658     case 'o':
4659         switch (len) {
4660         case 2:
4661             if (strEQ(d,"or"))                  return -KEY_or;
4662             break;
4663         case 3:
4664             if (strEQ(d,"ord"))                 return -KEY_ord;
4665             if (strEQ(d,"oct"))                 return -KEY_oct;
4666             if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4667                                                 return 0;}
4668             break;
4669         case 4:
4670             if (strEQ(d,"open"))                return -KEY_open;
4671             break;
4672         case 7:
4673             if (strEQ(d,"opendir"))             return -KEY_opendir;
4674             break;
4675         }
4676         break;
4677     case 'p':
4678         switch (len) {
4679         case 3:
4680             if (strEQ(d,"pop"))                 return KEY_pop;
4681             if (strEQ(d,"pos"))                 return KEY_pos;
4682             break;
4683         case 4:
4684             if (strEQ(d,"push"))                return KEY_push;
4685             if (strEQ(d,"pack"))                return -KEY_pack;
4686             if (strEQ(d,"pipe"))                return -KEY_pipe;
4687             break;
4688         case 5:
4689             if (strEQ(d,"print"))               return KEY_print;
4690             break;
4691         case 6:
4692             if (strEQ(d,"printf"))              return KEY_printf;
4693             break;
4694         case 7:
4695             if (strEQ(d,"package"))             return KEY_package;
4696             break;
4697         case 9:
4698             if (strEQ(d,"prototype"))           return KEY_prototype;
4699         }
4700         break;
4701     case 'q':
4702         if (len <= 2) {
4703             if (strEQ(d,"q"))                   return KEY_q;
4704             if (strEQ(d,"qr"))                  return KEY_qr;
4705             if (strEQ(d,"qq"))                  return KEY_qq;
4706             if (strEQ(d,"qw"))                  return KEY_qw;
4707             if (strEQ(d,"qx"))                  return KEY_qx;
4708         }
4709         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
4710         break;
4711     case 'r':
4712         switch (len) {
4713         case 3:
4714             if (strEQ(d,"ref"))                 return -KEY_ref;
4715             break;
4716         case 4:
4717             if (strEQ(d,"read"))                return -KEY_read;
4718             if (strEQ(d,"rand"))                return -KEY_rand;
4719             if (strEQ(d,"recv"))                return -KEY_recv;
4720             if (strEQ(d,"redo"))                return KEY_redo;
4721             break;
4722         case 5:
4723             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
4724             if (strEQ(d,"reset"))               return -KEY_reset;
4725             break;
4726         case 6:
4727             if (strEQ(d,"return"))              return KEY_return;
4728             if (strEQ(d,"rename"))              return -KEY_rename;
4729             if (strEQ(d,"rindex"))              return -KEY_rindex;
4730             break;
4731         case 7:
4732             if (strEQ(d,"require"))             return -KEY_require;
4733             if (strEQ(d,"reverse"))             return -KEY_reverse;
4734             if (strEQ(d,"readdir"))             return -KEY_readdir;
4735             break;
4736         case 8:
4737             if (strEQ(d,"readlink"))            return -KEY_readlink;
4738             if (strEQ(d,"readline"))            return -KEY_readline;
4739             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
4740             break;
4741         case 9:
4742             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
4743             break;
4744         }
4745         break;
4746     case 's':
4747         switch (d[1]) {
4748         case 0:                                 return KEY_s;
4749         case 'c':
4750             if (strEQ(d,"scalar"))              return KEY_scalar;
4751             break;
4752         case 'e':
4753             switch (len) {
4754             case 4:
4755                 if (strEQ(d,"seek"))            return -KEY_seek;
4756                 if (strEQ(d,"send"))            return -KEY_send;
4757                 break;
4758             case 5:
4759                 if (strEQ(d,"semop"))           return -KEY_semop;
4760                 break;
4761             case 6:
4762                 if (strEQ(d,"select"))          return -KEY_select;
4763                 if (strEQ(d,"semctl"))          return -KEY_semctl;
4764                 if (strEQ(d,"semget"))          return -KEY_semget;
4765                 break;
4766             case 7:
4767                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
4768                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
4769                 break;
4770             case 8:
4771                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
4772                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
4773                 break;
4774             case 9:
4775                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
4776                 break;
4777             case 10:
4778                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
4779                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
4780                 if (strEQ(d,"setservent"))      return -KEY_setservent;
4781                 break;
4782             case 11:
4783                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
4784                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
4785                 break;
4786             }
4787             break;
4788         case 'h':
4789             switch (len) {
4790             case 5:
4791                 if (strEQ(d,"shift"))           return KEY_shift;
4792                 break;
4793             case 6:
4794                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
4795                 if (strEQ(d,"shmget"))          return -KEY_shmget;
4796                 break;
4797             case 7:
4798                 if (strEQ(d,"shmread"))         return -KEY_shmread;
4799                 break;
4800             case 8:
4801                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
4802                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
4803                 break;
4804             }
4805             break;
4806         case 'i':
4807             if (strEQ(d,"sin"))                 return -KEY_sin;
4808             break;
4809         case 'l':
4810             if (strEQ(d,"sleep"))               return -KEY_sleep;
4811             break;
4812         case 'o':
4813             if (strEQ(d,"sort"))                return KEY_sort;
4814             if (strEQ(d,"socket"))              return -KEY_socket;
4815             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
4816             break;
4817         case 'p':
4818             if (strEQ(d,"split"))               return KEY_split;
4819             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
4820             if (strEQ(d,"splice"))              return KEY_splice;
4821             break;
4822         case 'q':
4823             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
4824             break;
4825         case 'r':
4826             if (strEQ(d,"srand"))               return -KEY_srand;
4827             break;
4828         case 't':
4829             if (strEQ(d,"stat"))                return -KEY_stat;
4830             if (strEQ(d,"study"))               return KEY_study;
4831             break;
4832         case 'u':
4833             if (strEQ(d,"substr"))              return -KEY_substr;
4834             if (strEQ(d,"sub"))                 return KEY_sub;
4835             break;
4836         case 'y':
4837             switch (len) {
4838             case 6:
4839                 if (strEQ(d,"system"))          return -KEY_system;
4840                 break;
4841             case 7:
4842                 if (strEQ(d,"symlink"))         return -KEY_symlink;
4843                 if (strEQ(d,"syscall"))         return -KEY_syscall;
4844                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
4845                 if (strEQ(d,"sysread"))         return -KEY_sysread;
4846                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
4847                 break;
4848             case 8:
4849                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
4850                 break;
4851             }
4852             break;
4853         }
4854         break;
4855     case 't':
4856         switch (len) {
4857         case 2:
4858             if (strEQ(d,"tr"))                  return KEY_tr;
4859             break;
4860         case 3:
4861             if (strEQ(d,"tie"))                 return KEY_tie;
4862             break;
4863         case 4:
4864             if (strEQ(d,"tell"))                return -KEY_tell;
4865             if (strEQ(d,"tied"))                return KEY_tied;
4866             if (strEQ(d,"time"))                return -KEY_time;
4867             break;
4868         case 5:
4869             if (strEQ(d,"times"))               return -KEY_times;
4870             break;
4871         case 7:
4872             if (strEQ(d,"telldir"))             return -KEY_telldir;
4873             break;
4874         case 8:
4875             if (strEQ(d,"truncate"))            return -KEY_truncate;
4876             break;
4877         }
4878         break;
4879     case 'u':
4880         switch (len) {
4881         case 2:
4882             if (strEQ(d,"uc"))                  return -KEY_uc;
4883             break;
4884         case 3:
4885             if (strEQ(d,"use"))                 return KEY_use;
4886             break;
4887         case 5:
4888             if (strEQ(d,"undef"))               return KEY_undef;
4889             if (strEQ(d,"until"))               return KEY_until;
4890             if (strEQ(d,"untie"))               return KEY_untie;
4891             if (strEQ(d,"utime"))               return -KEY_utime;
4892             if (strEQ(d,"umask"))               return -KEY_umask;
4893             break;
4894         case 6:
4895             if (strEQ(d,"unless"))              return KEY_unless;
4896             if (strEQ(d,"unpack"))              return -KEY_unpack;
4897             if (strEQ(d,"unlink"))              return -KEY_unlink;
4898             break;
4899         case 7:
4900             if (strEQ(d,"unshift"))             return KEY_unshift;
4901             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
4902             break;
4903         }
4904         break;
4905     case 'v':
4906         if (strEQ(d,"values"))                  return -KEY_values;
4907         if (strEQ(d,"vec"))                     return -KEY_vec;
4908         break;
4909     case 'w':
4910         switch (len) {
4911         case 4:
4912             if (strEQ(d,"warn"))                return -KEY_warn;
4913             if (strEQ(d,"wait"))                return -KEY_wait;
4914             break;
4915         case 5:
4916             if (strEQ(d,"while"))               return KEY_while;
4917             if (strEQ(d,"write"))               return -KEY_write;
4918             break;
4919         case 7:
4920             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
4921             break;
4922         case 9:
4923             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
4924             break;
4925         }
4926         break;
4927     case 'x':
4928         if (len == 1)                           return -KEY_x;
4929         if (strEQ(d,"xor"))                     return -KEY_xor;
4930         break;
4931     case 'y':
4932         if (len == 1)                           return KEY_y;
4933         break;
4934     case 'z':
4935         break;
4936     }
4937     return 0;
4938 }
4939
4940 STATIC void
4941 checkcomma(register char *s, char *name, char *what)
4942 {
4943     char *w;
4944
4945     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
4946         dTHR;                           /* only for ckWARN */
4947         if (ckWARN(WARN_SYNTAX)) {
4948             int level = 1;
4949             for (w = s+2; *w && level; w++) {
4950                 if (*w == '(')
4951                     ++level;
4952                 else if (*w == ')')
4953                     --level;
4954             }
4955             if (*w)
4956                 for (; *w && isSPACE(*w); w++) ;
4957             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
4958                 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4959         }
4960     }
4961     while (s < PL_bufend && isSPACE(*s))
4962         s++;
4963     if (*s == '(')
4964         s++;
4965     while (s < PL_bufend && isSPACE(*s))
4966         s++;
4967     if (isIDFIRST_lazy(s)) {
4968         w = s++;
4969         while (isALNUM_lazy(s))
4970             s++;
4971         while (s < PL_bufend && isSPACE(*s))
4972             s++;
4973         if (*s == ',') {
4974             int kw;
4975             *s = '\0';
4976             kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4977             *s = ',';
4978             if (kw)
4979                 return;
4980             croak("No comma allowed after %s", what);
4981         }
4982     }
4983 }
4984
4985 STATIC SV *
4986 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4987 {
4988     dSP;
4989     HV *table = GvHV(PL_hintgv);                 /* ^H */
4990     BINOP myop;
4991     SV *res;
4992     bool oldcatch = CATCH_GET;
4993     SV **cvp;
4994     SV *cv, *typesv;
4995
4996     if (!table) {
4997         yyerror("%^H is not defined");
4998         return sv;
4999     }
5000     cvp = hv_fetch(table, key, strlen(key), FALSE);
5001     if (!cvp || !SvOK(*cvp)) {
5002         char buf[128];
5003         sprintf(buf,"$^H{%s} is not defined", key);
5004         yyerror(buf);
5005         return sv;
5006     }
5007     sv_2mortal(sv);                     /* Parent created it permanently */
5008     cv = *cvp;
5009     if (!pv)
5010         pv = sv_2mortal(newSVpv(s, len));
5011     if (type)
5012         typesv = sv_2mortal(newSVpv(type, 0));
5013     else
5014         typesv = &PL_sv_undef;
5015     CATCH_SET(TRUE);
5016     Zero(&myop, 1, BINOP);
5017     myop.op_last = (OP *) &myop;
5018     myop.op_next = Nullop;
5019     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
5020
5021     PUSHSTACKi(PERLSI_OVERLOAD);
5022     ENTER;
5023     SAVEOP();
5024     PL_op = (OP *) &myop;
5025     if (PERLDB_SUB && PL_curstash != PL_debstash)
5026         PL_op->op_private |= OPpENTERSUB_DB;
5027     PUTBACK;
5028     pp_pushmark(ARGS);
5029
5030     EXTEND(sp, 4);
5031     PUSHs(pv);
5032     PUSHs(sv);
5033     PUSHs(typesv);
5034     PUSHs(cv);
5035     PUTBACK;
5036
5037     if (PL_op = pp_entersub(ARGS))
5038       CALLRUNOPS();
5039     LEAVE;
5040     SPAGAIN;
5041
5042     res = POPs;
5043     PUTBACK;
5044     CATCH_SET(oldcatch);
5045     POPSTACK;
5046
5047     if (!SvOK(res)) {
5048         char buf[128];
5049         sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5050         yyerror(buf);
5051     }
5052     return SvREFCNT_inc(res);
5053 }
5054
5055 STATIC char *
5056 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5057 {
5058     register char *d = dest;
5059     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
5060     for (;;) {
5061         if (d >= e)
5062             croak(ident_too_long);
5063         if (isALNUM(*s))        /* UTF handled below */
5064             *d++ = *s++;
5065         else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5066             *d++ = ':';
5067             *d++ = ':';
5068             s++;
5069         }
5070         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5071             *d++ = *s++;
5072             *d++ = *s++;
5073         }
5074         else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5075             char *t = s + UTF8SKIP(s);
5076             while (*t & 0x80 && is_utf8_mark((U8*)t))
5077                 t += UTF8SKIP(t);
5078             if (d + (t - s) > e)
5079                 croak(ident_too_long);
5080             Copy(s, d, t - s, char);
5081             d += t - s;
5082             s = t;
5083         }
5084         else {
5085             *d = '\0';
5086             *slp = d - dest;
5087             return s;
5088         }
5089     }
5090 }
5091
5092 STATIC char *
5093 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5094 {
5095     register char *d;
5096     register char *e;
5097     char *bracket = 0;
5098     char funny = *s++;
5099
5100     if (PL_lex_brackets == 0)
5101         PL_lex_fakebrack = 0;
5102     if (isSPACE(*s))
5103         s = skipspace(s);
5104     d = dest;
5105     e = d + destlen - 3;        /* two-character token, ending NUL */
5106     if (isDIGIT(*s)) {
5107         while (isDIGIT(*s)) {
5108             if (d >= e)
5109                 croak(ident_too_long);
5110             *d++ = *s++;
5111         }
5112     }
5113     else {
5114         for (;;) {
5115             if (d >= e)
5116                 croak(ident_too_long);
5117             if (isALNUM(*s))    /* UTF handled below */
5118                 *d++ = *s++;
5119             else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5120                 *d++ = ':';
5121                 *d++ = ':';
5122                 s++;
5123             }
5124             else if (*s == ':' && s[1] == ':') {
5125                 *d++ = *s++;
5126                 *d++ = *s++;
5127             }
5128             else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5129                 char *t = s + UTF8SKIP(s);
5130                 while (*t & 0x80 && is_utf8_mark((U8*)t))
5131                     t += UTF8SKIP(t);
5132                 if (d + (t - s) > e)
5133                     croak(ident_too_long);
5134                 Copy(s, d, t - s, char);
5135                 d += t - s;
5136                 s = t;
5137             }
5138             else
5139                 break;
5140         }
5141     }
5142     *d = '\0';
5143     d = dest;
5144     if (*d) {
5145         if (PL_lex_state != LEX_NORMAL)
5146             PL_lex_state = LEX_INTERPENDMAYBE;
5147         return s;
5148     }
5149     if (*s == '$' && s[1] &&
5150         (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5151     {
5152         return s;
5153     }
5154     if (*s == '{') {
5155         bracket = s;
5156         s++;
5157     }
5158     else if (ck_uni)
5159         check_uni();
5160     if (s < send)
5161         *d = *s++;
5162     d[1] = '\0';
5163     if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5164         *d = toCTRL(*s);
5165         s++;
5166     }
5167     if (bracket) {
5168         if (isSPACE(s[-1])) {
5169             while (s < send) {
5170                 char ch = *s++;
5171                 if (ch != ' ' && ch != '\t') {
5172                     *d = ch;
5173                     break;
5174                 }
5175             }
5176         }
5177         if (isIDFIRST_lazy(d)) {
5178             d++;
5179             if (UTF) {
5180                 e = s;
5181                 while (e < send && isALNUM_lazy(e) || *e == ':') {
5182                     e += UTF8SKIP(e);
5183                     while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5184                         e += UTF8SKIP(e);
5185                 }
5186                 Copy(s, d, e - s, char);
5187                 d += e - s;
5188                 s = e;
5189             }
5190             else {
5191                 while (isALNUM(*s) || *s == ':')
5192                     *d++ = *s++;
5193             }
5194             *d = '\0';
5195             while (s < send && (*s == ' ' || *s == '\t')) s++;
5196             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5197                 dTHR;                   /* only for ckWARN */
5198                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5199                     char *brack = *s == '[' ? "[...]" : "{...}";
5200                     warner(WARN_AMBIGUOUS,
5201                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5202                         funny, dest, brack, funny, dest, brack);
5203                 }
5204                 PL_lex_fakebrack = PL_lex_brackets+1;
5205                 bracket++;
5206                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5207                 return s;
5208             }
5209         }
5210         if (*s == '}') {
5211             s++;
5212             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5213                 PL_lex_state = LEX_INTERPEND;
5214             if (funny == '#')
5215                 funny = '@';
5216             if (PL_lex_state == LEX_NORMAL) {
5217                 dTHR;                   /* only for ckWARN */
5218                 if (ckWARN(WARN_AMBIGUOUS) &&
5219                     (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5220                 {
5221                     warner(WARN_AMBIGUOUS,
5222                         "Ambiguous use of %c{%s} resolved to %c%s",
5223                         funny, dest, funny, dest);
5224                 }
5225             }
5226         }
5227         else {
5228             s = bracket;                /* let the parser handle it */
5229             *dest = '\0';
5230         }
5231     }
5232     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5233         PL_lex_state = LEX_INTERPEND;
5234     return s;
5235 }
5236
5237 void pmflag(U16 *pmfl, int ch)
5238 {
5239     if (ch == 'i')
5240         *pmfl |= PMf_FOLD;
5241     else if (ch == 'g')
5242         *pmfl |= PMf_GLOBAL;
5243     else if (ch == 'c')
5244         *pmfl |= PMf_CONTINUE;
5245     else if (ch == 'o')
5246         *pmfl |= PMf_KEEP;
5247     else if (ch == 'm')
5248         *pmfl |= PMf_MULTILINE;
5249     else if (ch == 's')
5250         *pmfl |= PMf_SINGLELINE;
5251     else if (ch == 'x')
5252         *pmfl |= PMf_EXTENDED;
5253 }
5254
5255 STATIC char *
5256 scan_pat(char *start, I32 type)
5257 {
5258     PMOP *pm;
5259     char *s;
5260
5261     s = scan_str(start);
5262     if (!s) {
5263         if (PL_lex_stuff)
5264             SvREFCNT_dec(PL_lex_stuff);
5265         PL_lex_stuff = Nullsv;
5266         croak("Search pattern not terminated");
5267     }
5268
5269     pm = (PMOP*)newPMOP(type, 0);
5270     if (PL_multi_open == '?')
5271         pm->op_pmflags |= PMf_ONCE;
5272     if(type == OP_QR) {
5273         while (*s && strchr("iomsx", *s))
5274             pmflag(&pm->op_pmflags,*s++);
5275     }
5276     else {
5277         while (*s && strchr("iogcmsx", *s))
5278             pmflag(&pm->op_pmflags,*s++);
5279     }
5280     pm->op_pmpermflags = pm->op_pmflags;
5281
5282     PL_lex_op = (OP*)pm;
5283     yylval.ival = OP_MATCH;
5284     return s;
5285 }
5286
5287 STATIC char *
5288 scan_subst(char *start)
5289 {
5290     register char *s;
5291     register PMOP *pm;
5292     I32 first_start;
5293     I32 es = 0;
5294
5295     yylval.ival = OP_NULL;
5296
5297     s = scan_str(start);
5298
5299     if (!s) {
5300         if (PL_lex_stuff)
5301             SvREFCNT_dec(PL_lex_stuff);
5302         PL_lex_stuff = Nullsv;
5303         croak("Substitution pattern not terminated");
5304     }
5305
5306     if (s[-1] == PL_multi_open)
5307         s--;
5308
5309     first_start = PL_multi_start;
5310     s = scan_str(s);
5311     if (!s) {
5312         if (PL_lex_stuff)
5313             SvREFCNT_dec(PL_lex_stuff);
5314         PL_lex_stuff = Nullsv;
5315         if (PL_lex_repl)
5316             SvREFCNT_dec(PL_lex_repl);
5317         PL_lex_repl = Nullsv;
5318         croak("Substitution replacement not terminated");
5319     }
5320     PL_multi_start = first_start;       /* so whole substitution is taken together */
5321
5322     pm = (PMOP*)newPMOP(OP_SUBST, 0);
5323     while (*s) {
5324         if (*s == 'e') {
5325             s++;
5326             es++;
5327         }
5328         else if (strchr("iogcmsx", *s))
5329             pmflag(&pm->op_pmflags,*s++);
5330         else
5331             break;
5332     }
5333
5334     if (es) {
5335         SV *repl;
5336         pm->op_pmflags |= PMf_EVAL;
5337         repl = newSVpv("",0);
5338         while (es-- > 0)
5339             sv_catpv(repl, es ? "eval " : "do ");
5340         sv_catpvn(repl, "{ ", 2);
5341         sv_catsv(repl, PL_lex_repl);
5342         sv_catpvn(repl, " };", 2);
5343         SvCOMPILED_on(repl);
5344         SvREFCNT_dec(PL_lex_repl);
5345         PL_lex_repl = repl;
5346     }
5347
5348     pm->op_pmpermflags = pm->op_pmflags;
5349     PL_lex_op = (OP*)pm;
5350     yylval.ival = OP_SUBST;
5351     return s;
5352 }
5353
5354 STATIC char *
5355 scan_trans(char *start)
5356 {
5357     register char* s;
5358     OP *o;
5359     short *tbl;
5360     I32 squash;
5361     I32 del;
5362     I32 complement;
5363     I32 utf8;
5364     I32 count = 0;
5365
5366     yylval.ival = OP_NULL;
5367
5368     s = scan_str(start);
5369     if (!s) {
5370         if (PL_lex_stuff)
5371             SvREFCNT_dec(PL_lex_stuff);
5372         PL_lex_stuff = Nullsv;
5373         croak("Transliteration pattern not terminated");
5374     }
5375     if (s[-1] == PL_multi_open)
5376         s--;
5377
5378     s = scan_str(s);
5379     if (!s) {
5380         if (PL_lex_stuff)
5381             SvREFCNT_dec(PL_lex_stuff);
5382         PL_lex_stuff = Nullsv;
5383         if (PL_lex_repl)
5384             SvREFCNT_dec(PL_lex_repl);
5385         PL_lex_repl = Nullsv;
5386         croak("Transliteration replacement not terminated");
5387     }
5388
5389     if (UTF) {
5390         o = newSVOP(OP_TRANS, 0, 0);
5391         utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5392     }
5393     else {
5394         New(803,tbl,256,short);
5395         o = newPVOP(OP_TRANS, 0, (char*)tbl);
5396         utf8 = 0;
5397     }
5398
5399     complement = del = squash = 0;
5400     while (strchr("cdsCU", *s)) {
5401         if (*s == 'c')
5402             complement = OPpTRANS_COMPLEMENT;
5403         else if (*s == 'd')
5404             del = OPpTRANS_DELETE;
5405         else if (*s == 's')
5406             squash = OPpTRANS_SQUASH;
5407         else {
5408             switch (count++) {
5409             case 0:
5410                 if (*s == 'C')
5411                     utf8 &= ~OPpTRANS_FROM_UTF;
5412                 else
5413                     utf8 |= OPpTRANS_FROM_UTF;
5414                 break;
5415             case 1:
5416                 if (*s == 'C')
5417                     utf8 &= ~OPpTRANS_TO_UTF;
5418                 else
5419                     utf8 |= OPpTRANS_TO_UTF;
5420                 break;
5421             default:
5422                 croak("Too many /C and /U options");
5423             }
5424         }
5425         s++;
5426     }
5427     o->op_private = del|squash|complement|utf8;
5428
5429     PL_lex_op = o;
5430     yylval.ival = OP_TRANS;
5431     return s;
5432 }
5433
5434 STATIC char *
5435 scan_heredoc(register char *s)
5436 {
5437     dTHR;
5438     SV *herewas;
5439     I32 op_type = OP_SCALAR;
5440     I32 len;
5441     SV *tmpstr;
5442     char term;
5443     register char *d;
5444     register char *e;
5445     char *peek;
5446     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5447
5448     s += 2;
5449     d = PL_tokenbuf;
5450     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5451     if (!outer)
5452         *d++ = '\n';
5453     for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5454     if (*peek && strchr("`'\"",*peek)) {
5455         s = peek;
5456         term = *s++;
5457         s = delimcpy(d, e, s, PL_bufend, term, &len);
5458         d += len;
5459         if (s < PL_bufend)
5460             s++;
5461     }
5462     else {
5463         if (*s == '\\')
5464             s++, term = '\'';
5465         else
5466             term = '"';
5467         if (!isALNUM_lazy(s))
5468             deprecate("bare << to mean <<\"\"");
5469         for (; isALNUM_lazy(s); s++) {
5470             if (d < e)
5471                 *d++ = *s;
5472         }
5473     }
5474     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5475         croak("Delimiter for here document is too long");
5476     *d++ = '\n';
5477     *d = '\0';
5478     len = d - PL_tokenbuf;
5479 #ifndef PERL_STRICT_CR
5480     d = strchr(s, '\r');
5481     if (d) {
5482         char *olds = s;
5483         s = d;
5484         while (s < PL_bufend) {
5485             if (*s == '\r') {
5486                 *d++ = '\n';
5487                 if (*++s == '\n')
5488                     s++;
5489             }
5490             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
5491                 *d++ = *s++;
5492                 s++;
5493             }
5494             else
5495                 *d++ = *s++;
5496         }
5497         *d = '\0';
5498         PL_bufend = d;
5499         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5500         s = olds;
5501     }
5502 #endif
5503     d = "\n";
5504     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5505         herewas = newSVpv(s,PL_bufend-s);
5506     else
5507         s--, herewas = newSVpv(s,d-s);
5508     s += SvCUR(herewas);
5509
5510     tmpstr = NEWSV(87,79);
5511     sv_upgrade(tmpstr, SVt_PVIV);
5512     if (term == '\'') {
5513         op_type = OP_CONST;
5514         SvIVX(tmpstr) = -1;
5515     }
5516     else if (term == '`') {
5517         op_type = OP_BACKTICK;
5518         SvIVX(tmpstr) = '\\';
5519     }
5520
5521     CLINE;
5522     PL_multi_start = PL_curcop->cop_line;
5523     PL_multi_open = PL_multi_close = '<';
5524     term = *PL_tokenbuf;
5525     if (!outer) {
5526         d = s;
5527         while (s < PL_bufend &&
5528           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5529             if (*s++ == '\n')
5530                 PL_curcop->cop_line++;
5531         }
5532         if (s >= PL_bufend) {
5533             PL_curcop->cop_line = PL_multi_start;
5534             missingterm(PL_tokenbuf);
5535         }
5536         sv_setpvn(tmpstr,d+1,s-d);
5537         s += len - 1;
5538         PL_curcop->cop_line++;  /* the preceding stmt passes a newline */
5539
5540         sv_catpvn(herewas,s,PL_bufend-s);
5541         sv_setsv(PL_linestr,herewas);
5542         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5543         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5544     }
5545     else
5546         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
5547     while (s >= PL_bufend) {    /* multiple line string? */
5548         if (!outer ||
5549          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5550             PL_curcop->cop_line = PL_multi_start;
5551             missingterm(PL_tokenbuf);
5552         }
5553         PL_curcop->cop_line++;
5554         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5555 #ifndef PERL_STRICT_CR
5556         if (PL_bufend - PL_linestart >= 2) {
5557             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5558                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5559             {
5560                 PL_bufend[-2] = '\n';
5561                 PL_bufend--;
5562                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5563             }
5564             else if (PL_bufend[-1] == '\r')
5565                 PL_bufend[-1] = '\n';
5566         }
5567         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5568             PL_bufend[-1] = '\n';
5569 #endif
5570         if (PERLDB_LINE && PL_curstash != PL_debstash) {
5571             SV *sv = NEWSV(88,0);
5572
5573             sv_upgrade(sv, SVt_PVMG);
5574             sv_setsv(sv,PL_linestr);
5575             av_store(GvAV(PL_curcop->cop_filegv),
5576               (I32)PL_curcop->cop_line,sv);
5577         }
5578         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5579             s = PL_bufend - 1;
5580             *s = ' ';
5581             sv_catsv(PL_linestr,herewas);
5582             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5583         }
5584         else {
5585             s = PL_bufend;
5586             sv_catsv(tmpstr,PL_linestr);
5587         }
5588     }
5589     PL_multi_end = PL_curcop->cop_line;
5590     s++;
5591     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5592         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5593         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5594     }
5595     SvREFCNT_dec(herewas);
5596     PL_lex_stuff = tmpstr;
5597     yylval.ival = op_type;
5598     return s;
5599 }
5600
5601 /* scan_inputsymbol
5602    takes: current position in input buffer
5603    returns: new position in input buffer
5604    side-effects: yylval and lex_op are set.
5605
5606    This code handles:
5607
5608    <>           read from ARGV
5609    <FH>         read from filehandle
5610    <pkg::FH>    read from package qualified filehandle
5611    <pkg'FH>     read from package qualified filehandle
5612    <$fh>        read from filehandle in $fh
5613    <*.h>        filename glob
5614
5615 */
5616
5617 STATIC char *
5618 scan_inputsymbol(char *start)
5619 {
5620     register char *s = start;           /* current position in buffer */
5621     register char *d;
5622     register char *e;
5623     I32 len;
5624
5625     d = PL_tokenbuf;                    /* start of temp holding space */
5626     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
5627     s = delimcpy(d, e, s + 1, PL_bufend, '>', &len);    /* extract until > */
5628
5629     /* die if we didn't have space for the contents of the <>,
5630        or if it didn't end
5631     */
5632
5633     if (len >= sizeof PL_tokenbuf)
5634         croak("Excessively long <> operator");
5635     if (s >= PL_bufend)
5636         croak("Unterminated <> operator");
5637
5638     s++;
5639
5640     /* check for <$fh>
5641        Remember, only scalar variables are interpreted as filehandles by
5642        this code.  Anything more complex (e.g., <$fh{$num}>) will be
5643        treated as a glob() call.
5644        This code makes use of the fact that except for the $ at the front,
5645        a scalar variable and a filehandle look the same.
5646     */
5647     if (*d == '$' && d[1]) d++;
5648
5649     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5650     while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5651         d++;
5652
5653     /* If we've tried to read what we allow filehandles to look like, and
5654        there's still text left, then it must be a glob() and not a getline.
5655        Use scan_str to pull out the stuff between the <> and treat it
5656        as nothing more than a string.
5657     */
5658
5659     if (d - PL_tokenbuf != len) {
5660         yylval.ival = OP_GLOB;
5661         set_csh();
5662         s = scan_str(start);
5663         if (!s)
5664            croak("Glob not terminated");
5665         return s;
5666     }
5667     else {
5668         /* we're in a filehandle read situation */
5669         d = PL_tokenbuf;
5670
5671         /* turn <> into <ARGV> */
5672         if (!len)
5673             (void)strcpy(d,"ARGV");
5674
5675         /* if <$fh>, create the ops to turn the variable into a
5676            filehandle
5677         */
5678         if (*d == '$') {
5679             I32 tmp;
5680
5681             /* try to find it in the pad for this block, otherwise find
5682                add symbol table ops
5683             */
5684             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5685                 OP *o = newOP(OP_PADSV, 0);
5686                 o->op_targ = tmp;
5687                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5688             }
5689             else {
5690                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5691                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5692                                             newUNOP(OP_RV2SV, 0,
5693                                                 newGVOP(OP_GV, 0, gv)));
5694             }
5695             PL_lex_op->op_flags |= OPf_SPECIAL;
5696             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5697             yylval.ival = OP_NULL;
5698         }
5699
5700         /* If it's none of the above, it must be a literal filehandle
5701            (<Foo::BAR> or <FOO>) so build a simple readline OP */
5702         else {
5703             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5704             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5705             yylval.ival = OP_NULL;
5706         }
5707     }
5708
5709     return s;
5710 }
5711
5712
5713 /* scan_str
5714    takes: start position in buffer
5715    returns: position to continue reading from buffer
5716    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5717         updates the read buffer.
5718
5719    This subroutine pulls a string out of the input.  It is called for:
5720         q               single quotes           q(literal text)
5721         '               single quotes           'literal text'
5722         qq              double quotes           qq(interpolate $here please)
5723         "               double quotes           "interpolate $here please"
5724         qx              backticks               qx(/bin/ls -l)
5725         `               backticks               `/bin/ls -l`
5726         qw              quote words             @EXPORT_OK = qw( func() $spam )
5727         m//             regexp match            m/this/
5728         s///            regexp substitute       s/this/that/
5729         tr///           string transliterate    tr/this/that/
5730         y///            string transliterate    y/this/that/
5731         ($*@)           sub prototypes          sub foo ($)
5732         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
5733
5734    In most of these cases (all but <>, patterns and transliterate)
5735    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
5736    calls scan_str().  s/// makes yylex() call scan_subst() which calls
5737    scan_str().  tr/// and y/// make yylex() call scan_trans() which
5738    calls scan_str().
5739
5740    It skips whitespace before the string starts, and treats the first
5741    character as the delimiter.  If the delimiter is one of ([{< then
5742    the corresponding "close" character )]}> is used as the closing
5743    delimiter.  It allows quoting of delimiters, and if the string has
5744    balanced delimiters ([{<>}]) it allows nesting.
5745
5746    The lexer always reads these strings into lex_stuff, except in the
5747    case of the operators which take *two* arguments (s/// and tr///)
5748    when it checks to see if lex_stuff is full (presumably with the 1st
5749    arg to s or tr) and if so puts the string into lex_repl.
5750
5751 */
5752
5753 STATIC char *
5754 scan_str(char *start)
5755 {
5756     dTHR;
5757     SV *sv;                             /* scalar value: string */
5758     char *tmps;                         /* temp string, used for delimiter matching */
5759     register char *s = start;           /* current position in the buffer */
5760     register char term;                 /* terminating character */
5761     register char *to;                  /* current position in the sv's data */
5762     I32 brackets = 1;                   /* bracket nesting level */
5763
5764     /* skip space before the delimiter */
5765     if (isSPACE(*s))
5766         s = skipspace(s);
5767
5768     /* mark where we are, in case we need to report errors */
5769     CLINE;
5770
5771     /* after skipping whitespace, the next character is the terminator */
5772     term = *s;
5773     /* mark where we are */
5774     PL_multi_start = PL_curcop->cop_line;
5775     PL_multi_open = term;
5776
5777     /* find corresponding closing delimiter */
5778     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5779         term = tmps[5];
5780     PL_multi_close = term;
5781
5782     /* create a new SV to hold the contents.  87 is leak category, I'm
5783        assuming.  79 is the SV's initial length.  What a random number. */
5784     sv = NEWSV(87,79);
5785     sv_upgrade(sv, SVt_PVIV);
5786     SvIVX(sv) = term;
5787     (void)SvPOK_only(sv);               /* validate pointer */
5788
5789     /* move past delimiter and try to read a complete string */
5790     s++;
5791     for (;;) {
5792         /* extend sv if need be */
5793         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5794         /* set 'to' to the next character in the sv's string */
5795         to = SvPVX(sv)+SvCUR(sv);
5796
5797         /* if open delimiter is the close delimiter read unbridle */
5798         if (PL_multi_open == PL_multi_close) {
5799             for (; s < PL_bufend; s++,to++) {
5800                 /* embedded newlines increment the current line number */
5801                 if (*s == '\n' && !PL_rsfp)
5802                     PL_curcop->cop_line++;
5803                 /* handle quoted delimiters */
5804                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5805                     if (s[1] == term)
5806                         s++;
5807                 /* any other quotes are simply copied straight through */
5808                     else
5809                         *to++ = *s++;
5810                 }
5811                 /* terminate when run out of buffer (the for() condition), or
5812                    have found the terminator */
5813                 else if (*s == term)
5814                     break;
5815                 *to = *s;
5816             }
5817         }
5818
5819         /* if the terminator isn't the same as the start character (e.g.,
5820            matched brackets), we have to allow more in the quoting, and
5821            be prepared for nested brackets.
5822         */
5823         else {
5824             /* read until we run out of string, or we find the terminator */
5825             for (; s < PL_bufend; s++,to++) {
5826                 /* embedded newlines increment the line count */
5827                 if (*s == '\n' && !PL_rsfp)
5828                     PL_curcop->cop_line++;
5829                 /* backslashes can escape the open or closing characters */
5830                 if (*s == '\\' && s+1 < PL_bufend) {
5831                     if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5832                         s++;
5833                     else
5834                         *to++ = *s++;
5835                 }
5836                 /* allow nested opens and closes */
5837                 else if (*s == PL_multi_close && --brackets <= 0)
5838                     break;
5839                 else if (*s == PL_multi_open)
5840                     brackets++;
5841                 *to = *s;
5842             }
5843         }
5844         /* terminate the copied string and update the sv's end-of-string */
5845         *to = '\0';
5846         SvCUR_set(sv, to - SvPVX(sv));
5847
5848         /*
5849          * this next chunk reads more into the buffer if we're not done yet
5850          */
5851
5852         if (s < PL_bufend) break;       /* handle case where we are done yet :-) */
5853
5854 #ifndef PERL_STRICT_CR
5855         if (to - SvPVX(sv) >= 2) {
5856             if ((to[-2] == '\r' && to[-1] == '\n') ||
5857                 (to[-2] == '\n' && to[-1] == '\r'))
5858             {
5859                 to[-2] = '\n';
5860                 to--;
5861                 SvCUR_set(sv, to - SvPVX(sv));
5862             }
5863             else if (to[-1] == '\r')
5864                 to[-1] = '\n';
5865         }
5866         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5867             to[-1] = '\n';
5868 #endif
5869
5870         /* if we're out of file, or a read fails, bail and reset the current
5871            line marker so we can report where the unterminated string began
5872         */
5873         if (!PL_rsfp ||
5874          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5875             sv_free(sv);
5876             PL_curcop->cop_line = PL_multi_start;
5877             return Nullch;
5878         }
5879         /* we read a line, so increment our line counter */
5880         PL_curcop->cop_line++;
5881
5882         /* update debugger info */
5883         if (PERLDB_LINE && PL_curstash != PL_debstash) {
5884             SV *sv = NEWSV(88,0);
5885
5886             sv_upgrade(sv, SVt_PVMG);
5887             sv_setsv(sv,PL_linestr);
5888             av_store(GvAV(PL_curcop->cop_filegv),
5889               (I32)PL_curcop->cop_line, sv);
5890         }
5891
5892         /* having changed the buffer, we must update PL_bufend */
5893         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5894     }
5895
5896     /* at this point, we have successfully read the delimited string */
5897
5898     PL_multi_end = PL_curcop->cop_line;
5899     s++;
5900
5901     /* if we allocated too much space, give some back */
5902     if (SvCUR(sv) + 5 < SvLEN(sv)) {
5903         SvLEN_set(sv, SvCUR(sv) + 1);
5904         Renew(SvPVX(sv), SvLEN(sv), char);
5905     }
5906
5907     /* decide whether this is the first or second quoted string we've read
5908        for this op
5909     */
5910
5911     if (PL_lex_stuff)
5912         PL_lex_repl = sv;
5913     else
5914         PL_lex_stuff = sv;
5915     return s;
5916 }
5917
5918 /*
5919   scan_num
5920   takes: pointer to position in buffer
5921   returns: pointer to new position in buffer
5922   side-effects: builds ops for the constant in yylval.op
5923
5924   Read a number in any of the formats that Perl accepts:
5925
5926   0(x[0-7A-F]+)|([0-7]+)|(b[01])
5927   [\d_]+(\.[\d_]*)?[Ee](\d+)
5928
5929   Underbars (_) are allowed in decimal numbers.  If -w is on,
5930   underbars before a decimal point must be at three digit intervals.
5931
5932   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5933   thing it reads.
5934
5935   If it reads a number without a decimal point or an exponent, it will
5936   try converting the number to an integer and see if it can do so
5937   without loss of precision.
5938 */
5939
5940 char *
5941 scan_num(char *start)
5942 {
5943     register char *s = start;           /* current position in buffer */
5944     register char *d;                   /* destination in temp buffer */
5945     register char *e;                   /* end of temp buffer */
5946     I32 tryiv;                          /* used to see if it can be an int */
5947     double value;                       /* number read, as a double */
5948     SV *sv;                             /* place to put the converted number */
5949     I32 floatit;                        /* boolean: int or float? */
5950     char *lastub = 0;                   /* position of last underbar */
5951     static char number_too_long[] = "Number too long";
5952
5953     /* We use the first character to decide what type of number this is */
5954
5955     switch (*s) {
5956     default:
5957       croak("panic: scan_num");
5958
5959     /* if it starts with a 0, it could be an octal number, a decimal in
5960        0.13 disguise, or a hexadecimal number, or a binary number.
5961     */
5962     case '0':
5963         {
5964           /* variables:
5965              u          holds the "number so far"
5966              shift      the power of 2 of the base
5967                         (hex == 4, octal == 3, binary == 1)
5968              overflowed was the number more than we can hold?
5969
5970              Shift is used when we add a digit.  It also serves as an "are
5971              we in octal/hex/binary?" indicator to disallow hex characters
5972              when in octal mode.
5973            */
5974             UV u;
5975             I32 shift;
5976             bool overflowed = FALSE;
5977
5978             /* check for hex */
5979             if (s[1] == 'x') {
5980                 shift = 4;
5981                 s += 2;
5982             } else if (s[1] == 'b') {
5983                 shift = 1;
5984                 s += 2;
5985             }
5986             /* check for a decimal in disguise */
5987             else if (s[1] == '.')
5988                 goto decimal;
5989             /* so it must be octal */
5990             else
5991                 shift = 3;
5992             u = 0;
5993
5994             /* read the rest of the number */
5995             for (;;) {
5996                 UV n, b;        /* n is used in the overflow test, b is the digit we're adding on */
5997
5998                 switch (*s) {
5999
6000                 /* if we don't mention it, we're done */
6001                 default:
6002                     goto out;
6003
6004                 /* _ are ignored */
6005                 case '_':
6006                     s++;
6007                     break;
6008
6009                 /* 8 and 9 are not octal */
6010                 case '8': case '9':
6011                     if (shift == 3)
6012                         yyerror("Illegal octal digit");
6013                     else
6014                         if (shift == 1)
6015                             yyerror("Illegal binary digit");
6016                     /* FALL THROUGH */
6017
6018                 /* octal digits */
6019                 case '2': case '3': case '4':
6020                 case '5': case '6': case '7':
6021                     if (shift == 1)
6022                         yyerror("Illegal binary digit");
6023                     /* FALL THROUGH */
6024
6025                 case '0': case '1':
6026                     b = *s++ & 15;              /* ASCII digit -> value of digit */
6027                     goto digit;
6028
6029                 /* hex digits */
6030                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6031                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6032                     /* make sure they said 0x */
6033                     if (shift != 4)
6034                         goto out;
6035                     b = (*s++ & 7) + 9;
6036
6037                     /* Prepare to put the digit we have onto the end
6038                        of the number so far.  We check for overflows.
6039                     */
6040
6041                   digit:
6042                     n = u << shift;     /* make room for the digit */
6043                     if (!overflowed && (n >> shift) != u
6044                         && !(PL_hints & HINT_NEW_BINARY)) {
6045                         warn("Integer overflow in %s number",
6046                              (shift == 4) ? "hex"
6047                              : ((shift == 3) ? "octal" : "binary"));
6048                         overflowed = TRUE;
6049                     }
6050                     u = n | b;          /* add the digit to the end */
6051                     break;
6052                 }
6053             }
6054
6055           /* if we get here, we had success: make a scalar value from
6056              the number.
6057           */
6058           out:
6059             sv = NEWSV(92,0);
6060             sv_setuv(sv, u);
6061             if ( PL_hints & HINT_NEW_BINARY)
6062                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6063         }
6064         break;
6065
6066     /*
6067       handle decimal numbers.
6068       we're also sent here when we read a 0 as the first digit
6069     */
6070     case '1': case '2': case '3': case '4': case '5':
6071     case '6': case '7': case '8': case '9': case '.':
6072       decimal:
6073         d = PL_tokenbuf;
6074         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6075         floatit = FALSE;
6076
6077         /* read next group of digits and _ and copy into d */
6078         while (isDIGIT(*s) || *s == '_') {
6079             /* skip underscores, checking for misplaced ones
6080                if -w is on
6081             */
6082             if (*s == '_') {
6083                 dTHR;                   /* only for ckWARN */
6084                 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6085                     warner(WARN_SYNTAX, "Misplaced _ in number");
6086                 lastub = ++s;
6087             }
6088             else {
6089                 /* check for end of fixed-length buffer */
6090                 if (d >= e)
6091                     croak(number_too_long);
6092                 /* if we're ok, copy the character */
6093                 *d++ = *s++;
6094             }
6095         }
6096
6097         /* final misplaced underbar check */
6098         if (lastub && s - lastub != 3) {
6099             dTHR;
6100             if (ckWARN(WARN_SYNTAX))
6101                 warner(WARN_SYNTAX, "Misplaced _ in number");
6102         }
6103
6104         /* read a decimal portion if there is one.  avoid
6105            3..5 being interpreted as the number 3. followed
6106            by .5
6107         */
6108         if (*s == '.' && s[1] != '.') {
6109             floatit = TRUE;
6110             *d++ = *s++;
6111
6112             /* copy, ignoring underbars, until we run out of
6113                digits.  Note: no misplaced underbar checks!
6114             */
6115             for (; isDIGIT(*s) || *s == '_'; s++) {
6116                 /* fixed length buffer check */
6117                 if (d >= e)
6118                     croak(number_too_long);
6119                 if (*s != '_')
6120                     *d++ = *s;
6121             }
6122         }
6123
6124         /* read exponent part, if present */
6125         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6126             floatit = TRUE;
6127             s++;
6128
6129             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6130             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
6131
6132             /* allow positive or negative exponent */
6133             if (*s == '+' || *s == '-')
6134                 *d++ = *s++;
6135
6136             /* read digits of exponent (no underbars :-) */
6137             while (isDIGIT(*s)) {
6138                 if (d >= e)
6139                     croak(number_too_long);
6140                 *d++ = *s++;
6141             }
6142         }
6143
6144         /* terminate the string */
6145         *d = '\0';
6146
6147         /* make an sv from the string */
6148         sv = NEWSV(92,0);
6149         /* reset numeric locale in case we were earlier left in Swaziland */
6150         SET_NUMERIC_STANDARD();
6151         value = atof(PL_tokenbuf);
6152
6153         /*
6154            See if we can make do with an integer value without loss of
6155            precision.  We use I_V to cast to an int, because some
6156            compilers have issues.  Then we try casting it back and see
6157            if it was the same.  We only do this if we know we
6158            specifically read an integer.
6159
6160            Note: if floatit is true, then we don't need to do the
6161            conversion at all.
6162         */
6163         tryiv = I_V(value);
6164         if (!floatit && (double)tryiv == value)
6165             sv_setiv(sv, tryiv);
6166         else
6167             sv_setnv(sv, value);
6168         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6169             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6170                               (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6171         break;
6172     }
6173
6174     /* make the op for the constant and return */
6175
6176     yylval.opval = newSVOP(OP_CONST, 0, sv);
6177
6178     return s;
6179 }
6180
6181 STATIC char *
6182 scan_formline(register char *s)
6183 {
6184     dTHR;
6185     register char *eol;
6186     register char *t;
6187     SV *stuff = newSVpv("",0);
6188     bool needargs = FALSE;
6189
6190     while (!needargs) {
6191         if (*s == '.' || *s == '}') {
6192             /*SUPPRESS 530*/
6193 #ifdef PERL_STRICT_CR
6194             for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6195 #else
6196             for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6197 #endif
6198             if (*t == '\n' || t == PL_bufend)
6199                 break;
6200         }
6201         if (PL_in_eval && !PL_rsfp) {
6202             eol = strchr(s,'\n');
6203             if (!eol++)
6204                 eol = PL_bufend;
6205         }
6206         else
6207             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6208         if (*s != '#') {
6209             for (t = s; t < eol; t++) {
6210                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6211                     needargs = FALSE;
6212                     goto enough;        /* ~~ must be first line in formline */
6213                 }
6214                 if (*t == '@' || *t == '^')
6215                     needargs = TRUE;
6216             }
6217             sv_catpvn(stuff, s, eol-s);
6218         }
6219         s = eol;
6220         if (PL_rsfp) {
6221             s = filter_gets(PL_linestr, PL_rsfp, 0);
6222             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6223             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6224             if (!s) {
6225                 s = PL_bufptr;
6226                 yyerror("Format not terminated");
6227                 break;
6228             }
6229         }
6230         incline(s);
6231     }
6232   enough:
6233     if (SvCUR(stuff)) {
6234         PL_expect = XTERM;
6235         if (needargs) {
6236             PL_lex_state = LEX_NORMAL;
6237             PL_nextval[PL_nexttoke].ival = 0;
6238             force_next(',');
6239         }
6240         else
6241             PL_lex_state = LEX_FORMLINE;
6242         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6243         force_next(THING);
6244         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6245         force_next(LSTOP);
6246     }
6247     else {
6248         SvREFCNT_dec(stuff);
6249         PL_lex_formbrack = 0;
6250         PL_bufptr = s;
6251     }
6252     return s;
6253 }
6254
6255 STATIC void
6256 set_csh(void)
6257 {
6258 #ifdef CSH
6259     if (!PL_cshlen)
6260         PL_cshlen = strlen(PL_cshname);
6261 #endif
6262 }
6263
6264 I32
6265 start_subparse(I32 is_format, U32 flags)
6266 {
6267     dTHR;
6268     I32 oldsavestack_ix = PL_savestack_ix;
6269     CV* outsidecv = PL_compcv;
6270     AV* comppadlist;
6271
6272     if (PL_compcv) {
6273         assert(SvTYPE(PL_compcv) == SVt_PVCV);
6274     }
6275     save_I32(&PL_subline);
6276     save_item(PL_subname);
6277     SAVEI32(PL_padix);
6278     SAVESPTR(PL_curpad);
6279     SAVESPTR(PL_comppad);
6280     SAVESPTR(PL_comppad_name);
6281     SAVESPTR(PL_compcv);
6282     SAVEI32(PL_comppad_name_fill);
6283     SAVEI32(PL_min_intro_pending);
6284     SAVEI32(PL_max_intro_pending);
6285     SAVEI32(PL_pad_reset_pending);
6286
6287     PL_compcv = (CV*)NEWSV(1104,0);
6288     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6289     CvFLAGS(PL_compcv) |= flags;
6290
6291     PL_comppad = newAV();
6292     av_push(PL_comppad, Nullsv);
6293     PL_curpad = AvARRAY(PL_comppad);
6294     PL_comppad_name = newAV();
6295     PL_comppad_name_fill = 0;
6296     PL_min_intro_pending = 0;
6297     PL_padix = 0;
6298     PL_subline = PL_curcop->cop_line;
6299 #ifdef USE_THREADS
6300     av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6301     PL_curpad[0] = (SV*)newAV();
6302     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
6303 #endif /* USE_THREADS */
6304
6305     comppadlist = newAV();
6306     AvREAL_off(comppadlist);
6307     av_store(comppadlist, 0, (SV*)PL_comppad_name);
6308     av_store(comppadlist, 1, (SV*)PL_comppad);
6309
6310     CvPADLIST(PL_compcv) = comppadlist;
6311     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6312 #ifdef USE_THREADS
6313     CvOWNER(PL_compcv) = 0;
6314     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6315     MUTEX_INIT(CvMUTEXP(PL_compcv));
6316 #endif /* USE_THREADS */
6317
6318     return oldsavestack_ix;
6319 }
6320
6321 int
6322 yywarn(char *s)
6323 {
6324     dTHR;
6325     --PL_error_count;
6326     PL_in_eval |= 2;
6327     yyerror(s);
6328     PL_in_eval &= ~2;
6329     return 0;
6330 }
6331
6332 int
6333 yyerror(char *s)
6334 {
6335     dTHR;
6336     char *where = NULL;
6337     char *context = NULL;
6338     int contlen = -1;
6339     SV *msg;
6340
6341     if (!yychar || (yychar == ';' && !PL_rsfp))
6342         where = "at EOF";
6343     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6344       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6345         while (isSPACE(*PL_oldoldbufptr))
6346             PL_oldoldbufptr++;
6347         context = PL_oldoldbufptr;
6348         contlen = PL_bufptr - PL_oldoldbufptr;
6349     }
6350     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6351       PL_oldbufptr != PL_bufptr) {
6352         while (isSPACE(*PL_oldbufptr))
6353             PL_oldbufptr++;
6354         context = PL_oldbufptr;
6355         contlen = PL_bufptr - PL_oldbufptr;
6356     }
6357     else if (yychar > 255)
6358         where = "next token ???";
6359     else if ((yychar & 127) == 127) {
6360         if (PL_lex_state == LEX_NORMAL ||
6361            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6362             where = "at end of line";
6363         else if (PL_lex_inpat)
6364             where = "within pattern";
6365         else
6366             where = "within string";
6367     }
6368     else {
6369         SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6370         if (yychar < 32)
6371             sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6372         else if (isPRINT_LC(yychar))
6373             sv_catpvf(where_sv, "%c", yychar);
6374         else
6375             sv_catpvf(where_sv, "\\%03o", yychar & 255);
6376         where = SvPVX(where_sv);
6377     }
6378     msg = sv_2mortal(newSVpv(s, 0));
6379     sv_catpvf(msg, " at %_ line %ld, ",
6380               GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6381     if (context)
6382         sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6383     else
6384         sv_catpvf(msg, "%s\n", where);
6385     if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6386         sv_catpvf(msg,
6387         "  (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6388                 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6389         PL_multi_end = 0;
6390     }
6391     if (PL_in_eval & 2)
6392         warn("%_", msg);
6393     else if (PL_in_eval)
6394         sv_catsv(ERRSV, msg);
6395     else
6396         PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6397     if (++PL_error_count >= 10)
6398         croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6399     PL_in_my = 0;
6400     PL_in_my_stash = Nullhv;
6401     return 0;
6402 }
6403
6404