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