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