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