toke.c

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