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