toke.c

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