toke.c

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