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