toke.c

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