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                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3237                     PL_last_lop = PL_oldbufptr;
3238                     PL_last_lop_op = OP_ENTERSUB;
3239                     /* Is there a prototype? */
3240                     if (SvPOK(cv)) {
3241                         STRLEN len;
3242                         char *proto = SvPV((SV*)cv, len);
3243                         if (!len)
3244                             TERM(FUNC0SUB);
3245                         if (strEQ(proto, "$"))
3246                             OPERATOR(UNIOPSUB);
3247                         if (*proto == '&' && *s == '{') {
3248                             sv_setpv(PL_subname,"__ANON__");
3249                             PREBLOCK(LSTOPSUB);
3250                         }
3251                     }
3252                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3253                     PL_expect = XTERM;
3254                     force_next(WORD);
3255                     TOKEN(NOAMP);
3256                 }
3257
3258                 /* Call it a bare word */
3259
3260                 if (PL_hints & HINT_STRICT_SUBS)
3261                     yylval.opval->op_private |= OPpCONST_STRICT;
3262                 else {
3263                 bareword:
3264                     if (ckWARN(WARN_RESERVED)) {
3265                         if (lastchar != '-') {
3266                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3267                             if (!*d)
3268                                 warner(WARN_RESERVED, PL_warn_reserved,
3269                                        PL_tokenbuf);
3270                         }
3271                     }
3272                 }
3273
3274             safe_bareword:
3275                 if (lastchar && strchr("*%&", lastchar)) {
3276                     warn("Operator or semicolon missing before %c%s",
3277                         lastchar, PL_tokenbuf);
3278                     warn("Ambiguous use of %c resolved as operator %c",
3279                         lastchar, lastchar);
3280                 }
3281                 TOKEN(WORD);
3282             }
3283
3284         case KEY___FILE__:
3285             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3286                                         newSVsv(GvSV(PL_curcop->cop_filegv)));
3287             TERM(THING);
3288
3289         case KEY___LINE__:
3290             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3291                                     newSVpvf("%ld", (long)PL_curcop->cop_line));
3292             TERM(THING);
3293
3294         case KEY___PACKAGE__:
3295             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3296                                         (PL_curstash
3297                                          ? newSVsv(PL_curstname)
3298                                          : &PL_sv_undef));
3299             TERM(THING);
3300
3301         case KEY___DATA__:
3302         case KEY___END__: {
3303             GV *gv;
3304
3305             /*SUPPRESS 560*/
3306             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3307                 char *pname = "main";
3308                 if (PL_tokenbuf[2] == 'D')
3309                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3310                 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3311                 GvMULTI_on(gv);
3312                 if (!GvIO(gv))
3313                     GvIOp(gv) = newIO();
3314                 IoIFP(GvIOp(gv)) = PL_rsfp;
3315 #if defined(HAS_FCNTL) && defined(F_SETFD)
3316                 {
3317                     int fd = PerlIO_fileno(PL_rsfp);
3318                     fcntl(fd,F_SETFD,fd >= 3);
3319                 }
3320 #endif
3321                 /* Mark this internal pseudo-handle as clean */
3322                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3323                 if (PL_preprocess)
3324                     IoTYPE(GvIOp(gv)) = '|';
3325                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3326                     IoTYPE(GvIOp(gv)) = '-';
3327                 else
3328                     IoTYPE(GvIOp(gv)) = '<';
3329                 PL_rsfp = Nullfp;
3330             }
3331             goto fake_eof;
3332         }
3333
3334         case KEY_AUTOLOAD:
3335         case KEY_DESTROY:
3336         case KEY_BEGIN:
3337         case KEY_END:
3338         case KEY_INIT:
3339             if (PL_expect == XSTATE) {
3340                 s = PL_bufptr;
3341                 goto really_sub;
3342             }
3343             goto just_a_word;
3344
3345         case KEY_CORE:
3346             if (*s == ':' && s[1] == ':') {
3347                 s += 2;
3348                 d = s;
3349                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3350                 tmp = keyword(PL_tokenbuf, len);
3351                 if (tmp < 0)
3352                     tmp = -tmp;
3353                 goto reserved_word;
3354             }
3355             goto just_a_word;
3356
3357         case KEY_abs:
3358             UNI(OP_ABS);
3359
3360         case KEY_alarm:
3361             UNI(OP_ALARM);
3362
3363         case KEY_accept:
3364             LOP(OP_ACCEPT,XTERM);
3365
3366         case KEY_and:
3367             OPERATOR(ANDOP);
3368
3369         case KEY_atan2:
3370             LOP(OP_ATAN2,XTERM);
3371
3372         case KEY_bind:
3373             LOP(OP_BIND,XTERM);
3374
3375         case KEY_binmode:
3376             UNI(OP_BINMODE);
3377
3378         case KEY_bless:
3379             LOP(OP_BLESS,XTERM);
3380
3381         case KEY_chop:
3382             UNI(OP_CHOP);
3383
3384         case KEY_continue:
3385             PREBLOCK(CONTINUE);
3386
3387         case KEY_chdir:
3388             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3389             UNI(OP_CHDIR);
3390
3391         case KEY_close:
3392             UNI(OP_CLOSE);
3393
3394         case KEY_closedir:
3395             UNI(OP_CLOSEDIR);
3396
3397         case KEY_cmp:
3398             Eop(OP_SCMP);
3399
3400         case KEY_caller:
3401             UNI(OP_CALLER);
3402
3403         case KEY_crypt:
3404 #ifdef FCRYPT
3405             if (!PL_cryptseen++)
3406                 init_des();
3407 #endif
3408             LOP(OP_CRYPT,XTERM);
3409
3410         case KEY_chmod:
3411             if (ckWARN(WARN_OCTAL)) {
3412                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3413                 if (*d != '0' && isDIGIT(*d))
3414                     yywarn("chmod: mode argument is missing initial 0");
3415             }
3416             LOP(OP_CHMOD,XTERM);
3417
3418         case KEY_chown:
3419             LOP(OP_CHOWN,XTERM);
3420
3421         case KEY_connect:
3422             LOP(OP_CONNECT,XTERM);
3423
3424         case KEY_chr:
3425             UNI(OP_CHR);
3426
3427         case KEY_cos:
3428             UNI(OP_COS);
3429
3430         case KEY_chroot:
3431             UNI(OP_CHROOT);
3432
3433         case KEY_do:
3434             s = skipspace(s);
3435             if (*s == '{')
3436                 PRETERMBLOCK(DO);
3437             if (*s != '\'')
3438                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3439             OPERATOR(DO);
3440
3441         case KEY_die:
3442             PL_hints |= HINT_BLOCK_SCOPE;
3443             LOP(OP_DIE,XTERM);
3444
3445         case KEY_defined:
3446             UNI(OP_DEFINED);
3447
3448         case KEY_delete:
3449             UNI(OP_DELETE);
3450
3451         case KEY_dbmopen:
3452             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3453             LOP(OP_DBMOPEN,XTERM);
3454
3455         case KEY_dbmclose:
3456             UNI(OP_DBMCLOSE);
3457
3458         case KEY_dump:
3459             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3460             LOOPX(OP_DUMP);
3461
3462         case KEY_else:
3463             PREBLOCK(ELSE);
3464
3465         case KEY_elsif:
3466             yylval.ival = PL_curcop->cop_line;
3467             OPERATOR(ELSIF);
3468
3469         case KEY_eq:
3470             Eop(OP_SEQ);
3471
3472         case KEY_exists:
3473             UNI(OP_EXISTS);
3474
3475         case KEY_exit:
3476             UNI(OP_EXIT);
3477
3478         case KEY_eval:
3479             s = skipspace(s);
3480             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3481             UNIBRACK(OP_ENTEREVAL);
3482
3483         case KEY_eof:
3484             UNI(OP_EOF);
3485
3486         case KEY_exp:
3487             UNI(OP_EXP);
3488
3489         case KEY_each:
3490             UNI(OP_EACH);
3491
3492         case KEY_exec:
3493             set_csh();
3494             LOP(OP_EXEC,XREF);
3495
3496         case KEY_endhostent:
3497             FUN0(OP_EHOSTENT);
3498
3499         case KEY_endnetent:
3500             FUN0(OP_ENETENT);
3501
3502         case KEY_endservent:
3503             FUN0(OP_ESERVENT);
3504
3505         case KEY_endprotoent:
3506             FUN0(OP_EPROTOENT);
3507
3508         case KEY_endpwent:
3509             FUN0(OP_EPWENT);
3510
3511         case KEY_endgrent:
3512             FUN0(OP_EGRENT);
3513
3514         case KEY_for:
3515         case KEY_foreach:
3516             yylval.ival = PL_curcop->cop_line;
3517             s = skipspace(s);
3518             if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3519                 char *p = s;
3520                 if ((PL_bufend - p) >= 3 &&
3521                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3522                     p += 2;
3523                 p = skipspace(p);
3524                 if (isIDFIRST_lazy(p))
3525                     croak("Missing $ on loop variable");
3526             }
3527             OPERATOR(FOR);
3528
3529         case KEY_formline:
3530             LOP(OP_FORMLINE,XTERM);
3531
3532         case KEY_fork:
3533             FUN0(OP_FORK);
3534
3535         case KEY_fcntl:
3536             LOP(OP_FCNTL,XTERM);
3537
3538         case KEY_fileno:
3539             UNI(OP_FILENO);
3540
3541         case KEY_flock:
3542             LOP(OP_FLOCK,XTERM);
3543
3544         case KEY_gt:
3545             Rop(OP_SGT);
3546
3547         case KEY_ge:
3548             Rop(OP_SGE);
3549
3550         case KEY_grep:
3551             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3552
3553         case KEY_goto:
3554             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3555             LOOPX(OP_GOTO);
3556
3557         case KEY_gmtime:
3558             UNI(OP_GMTIME);
3559
3560         case KEY_getc:
3561             UNI(OP_GETC);
3562
3563         case KEY_getppid:
3564             FUN0(OP_GETPPID);
3565
3566         case KEY_getpgrp:
3567             UNI(OP_GETPGRP);
3568
3569         case KEY_getpriority:
3570             LOP(OP_GETPRIORITY,XTERM);
3571
3572         case KEY_getprotobyname:
3573             UNI(OP_GPBYNAME);
3574
3575         case KEY_getprotobynumber:
3576             LOP(OP_GPBYNUMBER,XTERM);
3577
3578         case KEY_getprotoent:
3579             FUN0(OP_GPROTOENT);
3580
3581         case KEY_getpwent:
3582             FUN0(OP_GPWENT);
3583
3584         case KEY_getpwnam:
3585             UNI(OP_GPWNAM);
3586
3587         case KEY_getpwuid:
3588             UNI(OP_GPWUID);
3589
3590         case KEY_getpeername:
3591             UNI(OP_GETPEERNAME);
3592
3593         case KEY_gethostbyname:
3594             UNI(OP_GHBYNAME);
3595
3596         case KEY_gethostbyaddr:
3597             LOP(OP_GHBYADDR,XTERM);
3598
3599         case KEY_gethostent:
3600             FUN0(OP_GHOSTENT);
3601
3602         case KEY_getnetbyname:
3603             UNI(OP_GNBYNAME);
3604
3605         case KEY_getnetbyaddr:
3606             LOP(OP_GNBYADDR,XTERM);
3607
3608         case KEY_getnetent:
3609             FUN0(OP_GNETENT);
3610
3611         case KEY_getservbyname:
3612             LOP(OP_GSBYNAME,XTERM);
3613
3614         case KEY_getservbyport:
3615             LOP(OP_GSBYPORT,XTERM);
3616
3617         case KEY_getservent:
3618             FUN0(OP_GSERVENT);
3619
3620         case KEY_getsockname:
3621             UNI(OP_GETSOCKNAME);
3622
3623         case KEY_getsockopt:
3624             LOP(OP_GSOCKOPT,XTERM);
3625
3626         case KEY_getgrent:
3627             FUN0(OP_GGRENT);
3628
3629         case KEY_getgrnam:
3630             UNI(OP_GGRNAM);
3631
3632         case KEY_getgrgid:
3633             UNI(OP_GGRGID);
3634
3635         case KEY_getlogin:
3636             FUN0(OP_GETLOGIN);
3637
3638         case KEY_glob:
3639             set_csh();
3640             LOP(OP_GLOB,XTERM);
3641
3642         case KEY_hex:
3643             UNI(OP_HEX);
3644
3645         case KEY_if:
3646             yylval.ival = PL_curcop->cop_line;
3647             OPERATOR(IF);
3648
3649         case KEY_index:
3650             LOP(OP_INDEX,XTERM);
3651
3652         case KEY_int:
3653             UNI(OP_INT);
3654
3655         case KEY_ioctl:
3656             LOP(OP_IOCTL,XTERM);
3657
3658         case KEY_join:
3659             LOP(OP_JOIN,XTERM);
3660
3661         case KEY_keys:
3662             UNI(OP_KEYS);
3663
3664         case KEY_kill:
3665             LOP(OP_KILL,XTERM);
3666
3667         case KEY_last:
3668             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3669             LOOPX(OP_LAST);
3670
3671         case KEY_lc:
3672             UNI(OP_LC);
3673
3674         case KEY_lcfirst:
3675             UNI(OP_LCFIRST);
3676
3677         case KEY_local:
3678             OPERATOR(LOCAL);
3679
3680         case KEY_length:
3681             UNI(OP_LENGTH);
3682
3683         case KEY_lt:
3684             Rop(OP_SLT);
3685
3686         case KEY_le:
3687             Rop(OP_SLE);
3688
3689         case KEY_localtime:
3690             UNI(OP_LOCALTIME);
3691
3692         case KEY_log:
3693             UNI(OP_LOG);
3694
3695         case KEY_link:
3696             LOP(OP_LINK,XTERM);
3697
3698         case KEY_listen:
3699             LOP(OP_LISTEN,XTERM);
3700
3701         case KEY_lock:
3702             UNI(OP_LOCK);
3703
3704         case KEY_lstat:
3705             UNI(OP_LSTAT);
3706
3707         case KEY_m:
3708             s = scan_pat(s,OP_MATCH);
3709             TERM(sublex_start());
3710
3711         case KEY_map:
3712             LOP(OP_MAPSTART, XREF);
3713
3714         case KEY_mkdir:
3715             LOP(OP_MKDIR,XTERM);
3716
3717         case KEY_msgctl:
3718             LOP(OP_MSGCTL,XTERM);
3719
3720         case KEY_msgget:
3721             LOP(OP_MSGGET,XTERM);
3722
3723         case KEY_msgrcv:
3724             LOP(OP_MSGRCV,XTERM);
3725
3726         case KEY_msgsnd:
3727             LOP(OP_MSGSND,XTERM);
3728
3729         case KEY_my:
3730             PL_in_my = TRUE;
3731             s = skipspace(s);
3732             if (isIDFIRST_lazy(s)) {
3733                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3734                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3735                 if (!PL_in_my_stash) {
3736                     char tmpbuf[1024];
3737                     PL_bufptr = s;
3738                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3739                     yyerror(tmpbuf);
3740                 }
3741             }
3742             OPERATOR(MY);
3743
3744         case KEY_next:
3745             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3746             LOOPX(OP_NEXT);
3747
3748         case KEY_ne:
3749             Eop(OP_SNE);
3750
3751         case KEY_no:
3752             if (PL_expect != XSTATE)
3753                 yyerror("\"no\" not allowed in expression");
3754             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3755             s = force_version(s);
3756             yylval.ival = 0;
3757             OPERATOR(USE);
3758
3759         case KEY_not:
3760             OPERATOR(NOTOP);
3761
3762         case KEY_open:
3763             s = skipspace(s);
3764             if (isIDFIRST_lazy(s)) {
3765                 char *t;
3766                 for (d = s; isALNUM_lazy(d); d++) ;
3767                 t = skipspace(d);
3768                 if (strchr("|&*+-=!?:.", *t))
3769                     warn("Precedence problem: open %.*s should be open(%.*s)",
3770                         d-s,s, d-s,s);
3771             }
3772             LOP(OP_OPEN,XTERM);
3773
3774         case KEY_or:
3775             yylval.ival = OP_OR;
3776             OPERATOR(OROP);
3777
3778         case KEY_ord:
3779             UNI(OP_ORD);
3780
3781         case KEY_oct:
3782             UNI(OP_OCT);
3783
3784         case KEY_opendir:
3785             LOP(OP_OPEN_DIR,XTERM);
3786
3787         case KEY_print:
3788             checkcomma(s,PL_tokenbuf,"filehandle");
3789             LOP(OP_PRINT,XREF);
3790
3791         case KEY_printf:
3792             checkcomma(s,PL_tokenbuf,"filehandle");
3793             LOP(OP_PRTF,XREF);
3794
3795         case KEY_prototype:
3796             UNI(OP_PROTOTYPE);
3797
3798         case KEY_push:
3799             LOP(OP_PUSH,XTERM);
3800
3801         case KEY_pop:
3802             UNI(OP_POP);
3803
3804         case KEY_pos:
3805             UNI(OP_POS);
3806
3807         case KEY_pack:
3808             LOP(OP_PACK,XTERM);
3809
3810         case KEY_package:
3811             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3812             OPERATOR(PACKAGE);
3813
3814         case KEY_pipe:
3815             LOP(OP_PIPE_OP,XTERM);
3816
3817         case KEY_q:
3818             s = scan_str(s);
3819             if (!s)
3820                 missingterm((char*)0);
3821             yylval.ival = OP_CONST;
3822             TERM(sublex_start());
3823
3824         case KEY_quotemeta:
3825             UNI(OP_QUOTEMETA);
3826
3827         case KEY_qw:
3828             s = scan_str(s);
3829             if (!s)
3830                 missingterm((char*)0);
3831             force_next(')');
3832             if (SvCUR(PL_lex_stuff)) {
3833                 OP *words = Nullop;
3834                 int warned = 0;
3835                 d = SvPV_force(PL_lex_stuff, len);
3836                 while (len) {
3837                     for (; isSPACE(*d) && len; --len, ++d) ;
3838                     if (len) {
3839                         char *b = d;
3840                         if (!warned && ckWARN(WARN_SYNTAX)) {
3841                             for (; !isSPACE(*d) && len; --len, ++d) {
3842                                 if (*d == ',') {
3843                                     warner(WARN_SYNTAX,
3844                                         "Possible attempt to separate words with commas");
3845                                     ++warned;
3846                                 }
3847                                 else if (*d == '#') {
3848                                     warner(WARN_SYNTAX,
3849                                         "Possible attempt to put comments in qw() list");
3850                                     ++warned;
3851                                 }
3852                             }
3853                         }
3854                         else {
3855                             for (; !isSPACE(*d) && len; --len, ++d) ;
3856                         }
3857                         words = append_elem(OP_LIST, words,
3858                                             newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
3859                     }
3860                 }
3861                 if (words) {
3862                     PL_nextval[PL_nexttoke].opval = words;
3863                     force_next(THING);
3864                 }
3865             }
3866             if (PL_lex_stuff)
3867                 SvREFCNT_dec(PL_lex_stuff);
3868             PL_lex_stuff = Nullsv;
3869             PL_expect = XTERM;
3870             TOKEN('(');
3871
3872         case KEY_qq:
3873             s = scan_str(s);
3874             if (!s)
3875                 missingterm((char*)0);
3876             yylval.ival = OP_STRINGIFY;
3877             if (SvIVX(PL_lex_stuff) == '\'')
3878                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
3879             TERM(sublex_start());
3880
3881         case KEY_qr:
3882             s = scan_pat(s,OP_QR);
3883             TERM(sublex_start());
3884
3885         case KEY_qx:
3886             s = scan_str(s);
3887             if (!s)
3888                 missingterm((char*)0);
3889             yylval.ival = OP_BACKTICK;
3890             set_csh();
3891             TERM(sublex_start());
3892
3893         case KEY_return:
3894             OLDLOP(OP_RETURN);
3895
3896         case KEY_require:
3897             *PL_tokenbuf = '\0';
3898             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3899             if (isIDFIRST_lazy(PL_tokenbuf))
3900                 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3901             else if (*s == '<')
3902                 yyerror("<> should be quotes");
3903             UNI(OP_REQUIRE);
3904
3905         case KEY_reset:
3906             UNI(OP_RESET);
3907
3908         case KEY_redo:
3909             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3910             LOOPX(OP_REDO);
3911
3912         case KEY_rename:
3913             LOP(OP_RENAME,XTERM);
3914
3915         case KEY_rand:
3916             UNI(OP_RAND);
3917
3918         case KEY_rmdir:
3919             UNI(OP_RMDIR);
3920
3921         case KEY_rindex:
3922             LOP(OP_RINDEX,XTERM);
3923
3924         case KEY_read:
3925             LOP(OP_READ,XTERM);
3926
3927         case KEY_readdir:
3928             UNI(OP_READDIR);
3929
3930         case KEY_readline:
3931             set_csh();
3932             UNI(OP_READLINE);
3933
3934         case KEY_readpipe:
3935             set_csh();
3936             UNI(OP_BACKTICK);
3937
3938         case KEY_rewinddir:
3939             UNI(OP_REWINDDIR);
3940
3941         case KEY_recv:
3942             LOP(OP_RECV,XTERM);
3943
3944         case KEY_reverse:
3945             LOP(OP_REVERSE,XTERM);
3946
3947         case KEY_readlink:
3948             UNI(OP_READLINK);
3949
3950         case KEY_ref:
3951             UNI(OP_REF);
3952
3953         case KEY_s:
3954             s = scan_subst(s);
3955             if (yylval.opval)
3956                 TERM(sublex_start());
3957             else
3958                 TOKEN(1);       /* force error */
3959
3960         case KEY_chomp:
3961             UNI(OP_CHOMP);
3962
3963         case KEY_scalar:
3964             UNI(OP_SCALAR);
3965
3966         case KEY_select:
3967             LOP(OP_SELECT,XTERM);
3968
3969         case KEY_seek:
3970             LOP(OP_SEEK,XTERM);
3971
3972         case KEY_semctl:
3973             LOP(OP_SEMCTL,XTERM);
3974
3975         case KEY_semget:
3976             LOP(OP_SEMGET,XTERM);
3977
3978         case KEY_semop:
3979             LOP(OP_SEMOP,XTERM);
3980
3981         case KEY_send:
3982             LOP(OP_SEND,XTERM);
3983
3984         case KEY_setpgrp:
3985             LOP(OP_SETPGRP,XTERM);
3986
3987         case KEY_setpriority:
3988             LOP(OP_SETPRIORITY,XTERM);
3989
3990         case KEY_sethostent:
3991             UNI(OP_SHOSTENT);
3992
3993         case KEY_setnetent:
3994             UNI(OP_SNETENT);
3995
3996         case KEY_setservent:
3997             UNI(OP_SSERVENT);
3998
3999         case KEY_setprotoent:
4000             UNI(OP_SPROTOENT);
4001
4002         case KEY_setpwent:
4003             FUN0(OP_SPWENT);
4004
4005         case KEY_setgrent:
4006             FUN0(OP_SGRENT);
4007
4008         case KEY_seekdir:
4009             LOP(OP_SEEKDIR,XTERM);
4010
4011         case KEY_setsockopt:
4012             LOP(OP_SSOCKOPT,XTERM);
4013
4014         case KEY_shift:
4015             UNI(OP_SHIFT);
4016
4017         case KEY_shmctl:
4018             LOP(OP_SHMCTL,XTERM);
4019
4020         case KEY_shmget:
4021             LOP(OP_SHMGET,XTERM);
4022
4023         case KEY_shmread:
4024             LOP(OP_SHMREAD,XTERM);
4025
4026         case KEY_shmwrite:
4027             LOP(OP_SHMWRITE,XTERM);
4028
4029         case KEY_shutdown:
4030             LOP(OP_SHUTDOWN,XTERM);
4031
4032         case KEY_sin:
4033             UNI(OP_SIN);
4034
4035         case KEY_sleep:
4036             UNI(OP_SLEEP);
4037
4038         case KEY_socket:
4039             LOP(OP_SOCKET,XTERM);
4040
4041         case KEY_socketpair:
4042             LOP(OP_SOCKPAIR,XTERM);
4043
4044         case KEY_sort:
4045             checkcomma(s,PL_tokenbuf,"subroutine name");
4046             s = skipspace(s);
4047             if (*s == ';' || *s == ')')         /* probably a close */
4048                 croak("sort is now a reserved word");
4049             PL_expect = XTERM;
4050             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4051             LOP(OP_SORT,XREF);
4052
4053         case KEY_split:
4054             LOP(OP_SPLIT,XTERM);
4055
4056         case KEY_sprintf:
4057             LOP(OP_SPRINTF,XTERM);
4058
4059         case KEY_splice:
4060             LOP(OP_SPLICE,XTERM);
4061
4062         case KEY_sqrt:
4063             UNI(OP_SQRT);
4064
4065         case KEY_srand:
4066             UNI(OP_SRAND);
4067
4068         case KEY_stat:
4069             UNI(OP_STAT);
4070
4071         case KEY_study:
4072             PL_sawstudy++;
4073             UNI(OP_STUDY);
4074
4075         case KEY_substr:
4076             LOP(OP_SUBSTR,XTERM);
4077
4078         case KEY_format:
4079         case KEY_sub:
4080           really_sub:
4081             s = skipspace(s);
4082
4083             if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4084                 char tmpbuf[sizeof PL_tokenbuf];
4085                 PL_expect = XBLOCK;
4086                 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4087                 if (strchr(tmpbuf, ':'))
4088                     sv_setpv(PL_subname, tmpbuf);
4089                 else {
4090                     sv_setsv(PL_subname,PL_curstname);
4091                     sv_catpvn(PL_subname,"::",2);
4092                     sv_catpvn(PL_subname,tmpbuf,len);
4093                 }
4094                 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4095                 s = skipspace(s);
4096             }
4097             else {
4098                 PL_expect = XTERMBLOCK;
4099                 sv_setpv(PL_subname,"?");
4100             }
4101
4102             if (tmp == KEY_format) {
4103                 s = skipspace(s);
4104                 if (*s == '=')
4105                     PL_lex_formbrack = PL_lex_brackets + 1;
4106                 OPERATOR(FORMAT);
4107             }
4108
4109             /* Look for a prototype */
4110             if (*s == '(') {
4111                 char *p;
4112
4113                 s = scan_str(s);
4114                 if (!s) {
4115                     if (PL_lex_stuff)
4116                         SvREFCNT_dec(PL_lex_stuff);
4117                     PL_lex_stuff = Nullsv;
4118                     croak("Prototype not terminated");
4119                 }
4120                 /* strip spaces */
4121                 d = SvPVX(PL_lex_stuff);
4122                 tmp = 0;
4123                 for (p = d; *p; ++p) {
4124                     if (!isSPACE(*p))
4125                         d[tmp++] = *p;
4126                 }
4127                 d[tmp] = '\0';
4128                 SvCUR(PL_lex_stuff) = tmp;
4129
4130                 PL_nexttoke++;
4131                 PL_nextval[1] = PL_nextval[0];
4132                 PL_nexttype[1] = PL_nexttype[0];
4133                 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4134                 PL_nexttype[0] = THING;
4135                 if (PL_nexttoke == 1) {
4136                     PL_lex_defer = PL_lex_state;
4137                     PL_lex_expect = PL_expect;
4138                     PL_lex_state = LEX_KNOWNEXT;
4139                 }
4140                 PL_lex_stuff = Nullsv;
4141             }
4142
4143             if (*SvPV(PL_subname,n_a) == '?') {
4144                 sv_setpv(PL_subname,"__ANON__");
4145                 TOKEN(ANONSUB);
4146             }
4147             PREBLOCK(SUB);
4148
4149         case KEY_system:
4150             set_csh();
4151             LOP(OP_SYSTEM,XREF);
4152
4153         case KEY_symlink:
4154             LOP(OP_SYMLINK,XTERM);
4155
4156         case KEY_syscall:
4157             LOP(OP_SYSCALL,XTERM);
4158
4159         case KEY_sysopen:
4160             LOP(OP_SYSOPEN,XTERM);
4161
4162         case KEY_sysseek:
4163             LOP(OP_SYSSEEK,XTERM);
4164
4165         case KEY_sysread:
4166             LOP(OP_SYSREAD,XTERM);
4167
4168         case KEY_syswrite:
4169             LOP(OP_SYSWRITE,XTERM);
4170
4171         case KEY_tr:
4172             s = scan_trans(s);
4173             TERM(sublex_start());
4174
4175         case KEY_tell:
4176             UNI(OP_TELL);
4177
4178         case KEY_telldir:
4179             UNI(OP_TELLDIR);
4180
4181         case KEY_tie:
4182             LOP(OP_TIE,XTERM);
4183
4184         case KEY_tied:
4185             UNI(OP_TIED);
4186
4187         case KEY_time:
4188             FUN0(OP_TIME);
4189
4190         case KEY_times:
4191             FUN0(OP_TMS);
4192
4193         case KEY_truncate:
4194             LOP(OP_TRUNCATE,XTERM);
4195
4196         case KEY_uc:
4197             UNI(OP_UC);
4198
4199         case KEY_ucfirst:
4200             UNI(OP_UCFIRST);
4201
4202         case KEY_untie:
4203             UNI(OP_UNTIE);
4204
4205         case KEY_until:
4206             yylval.ival = PL_curcop->cop_line;
4207             OPERATOR(UNTIL);
4208
4209         case KEY_unless:
4210             yylval.ival = PL_curcop->cop_line;
4211             OPERATOR(UNLESS);
4212
4213         case KEY_unlink:
4214             LOP(OP_UNLINK,XTERM);
4215
4216         case KEY_undef:
4217             UNI(OP_UNDEF);
4218
4219         case KEY_unpack:
4220             LOP(OP_UNPACK,XTERM);
4221
4222         case KEY_utime:
4223             LOP(OP_UTIME,XTERM);
4224
4225         case KEY_umask:
4226             if (ckWARN(WARN_OCTAL)) {
4227                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4228                 if (*d != '0' && isDIGIT(*d))
4229                     yywarn("umask: argument is missing initial 0");
4230             }
4231             UNI(OP_UMASK);
4232
4233         case KEY_unshift:
4234             LOP(OP_UNSHIFT,XTERM);
4235
4236         case KEY_use:
4237             if (PL_expect != XSTATE)
4238                 yyerror("\"use\" not allowed in expression");
4239             s = skipspace(s);
4240             if(isDIGIT(*s)) {
4241                 s = force_version(s);
4242                 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4243                     PL_nextval[PL_nexttoke].opval = Nullop;
4244                     force_next(WORD);
4245                 }
4246             }
4247             else {
4248                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4249                 s = force_version(s);
4250             }
4251             yylval.ival = 1;
4252             OPERATOR(USE);
4253
4254         case KEY_values:
4255             UNI(OP_VALUES);
4256
4257         case KEY_vec:
4258             PL_sawvec = TRUE;
4259             LOP(OP_VEC,XTERM);
4260
4261         case KEY_while:
4262             yylval.ival = PL_curcop->cop_line;
4263             OPERATOR(WHILE);
4264
4265         case KEY_warn:
4266             PL_hints |= HINT_BLOCK_SCOPE;
4267             LOP(OP_WARN,XTERM);
4268
4269         case KEY_wait:
4270             FUN0(OP_WAIT);
4271
4272         case KEY_waitpid:
4273             LOP(OP_WAITPID,XTERM);
4274
4275         case KEY_wantarray:
4276             FUN0(OP_WANTARRAY);
4277
4278         case KEY_write:
4279 #ifdef EBCDIC
4280         {
4281             static char ctl_l[2];
4282
4283             if (ctl_l[0] == '\0')
4284                 ctl_l[0] = toCTRL('L');
4285             gv_fetchpv(ctl_l,TRUE, SVt_PV);
4286         }
4287 #else
4288             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4289 #endif
4290             UNI(OP_ENTERWRITE);
4291
4292         case KEY_x:
4293             if (PL_expect == XOPERATOR)
4294                 Mop(OP_REPEAT);
4295             check_uni();
4296             goto just_a_word;
4297
4298         case KEY_xor:
4299             yylval.ival = OP_XOR;
4300             OPERATOR(OROP);
4301
4302         case KEY_y:
4303             s = scan_trans(s);
4304             TERM(sublex_start());
4305         }
4306     }}
4307 }
4308
4309 I32
4310 keyword(register char *d, I32 len)
4311 {
4312     switch (*d) {
4313     case '_':
4314         if (d[1] == '_') {
4315             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4316             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4317             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4318             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4319             if (strEQ(d,"__END__"))             return KEY___END__;
4320         }
4321         break;
4322     case 'A':
4323         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4324         break;
4325     case 'a':
4326         switch (len) {
4327         case 3:
4328             if (strEQ(d,"and"))                 return -KEY_and;
4329             if (strEQ(d,"abs"))                 return -KEY_abs;
4330             break;
4331         case 5:
4332             if (strEQ(d,"alarm"))               return -KEY_alarm;
4333             if (strEQ(d,"atan2"))               return -KEY_atan2;
4334             break;
4335         case 6:
4336             if (strEQ(d,"accept"))              return -KEY_accept;
4337             break;
4338         }
4339         break;
4340     case 'B':
4341         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4342         break;
4343     case 'b':
4344         if (strEQ(d,"bless"))                   return -KEY_bless;
4345         if (strEQ(d,"bind"))                    return -KEY_bind;
4346         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4347         break;
4348     case 'C':
4349         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4350         break;
4351     case 'c':
4352         switch (len) {
4353         case 3:
4354             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4355             if (strEQ(d,"chr"))                 return -KEY_chr;
4356             if (strEQ(d,"cos"))                 return -KEY_cos;
4357             break;
4358         case 4:
4359             if (strEQ(d,"chop"))                return KEY_chop;
4360             break;
4361         case 5:
4362             if (strEQ(d,"close"))               return -KEY_close;
4363             if (strEQ(d,"chdir"))               return -KEY_chdir;
4364             if (strEQ(d,"chomp"))               return KEY_chomp;
4365             if (strEQ(d,"chmod"))               return -KEY_chmod;
4366             if (strEQ(d,"chown"))               return -KEY_chown;
4367             if (strEQ(d,"crypt"))               return -KEY_crypt;
4368             break;
4369         case 6:
4370             if (strEQ(d,"chroot"))              return -KEY_chroot;
4371             if (strEQ(d,"caller"))              return -KEY_caller;
4372             break;
4373         case 7:
4374             if (strEQ(d,"connect"))             return -KEY_connect;
4375             break;
4376         case 8:
4377             if (strEQ(d,"closedir"))            return -KEY_closedir;
4378             if (strEQ(d,"continue"))            return -KEY_continue;
4379             break;
4380         }
4381         break;
4382     case 'D':
4383         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4384         break;
4385     case 'd':
4386         switch (len) {
4387         case 2:
4388             if (strEQ(d,"do"))                  return KEY_do;
4389             break;
4390         case 3:
4391             if (strEQ(d,"die"))                 return -KEY_die;
4392             break;
4393         case 4:
4394             if (strEQ(d,"dump"))                return -KEY_dump;
4395             break;
4396         case 6:
4397             if (strEQ(d,"delete"))              return KEY_delete;
4398             break;
4399         case 7:
4400             if (strEQ(d,"defined"))             return KEY_defined;
4401             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
4402             break;
4403         case 8:
4404             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
4405             break;
4406         }
4407         break;
4408     case 'E':
4409         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
4410         if (strEQ(d,"END"))                     return KEY_END;
4411         break;
4412     case 'e':
4413         switch (len) {
4414         case 2:
4415             if (strEQ(d,"eq"))                  return -KEY_eq;
4416             break;
4417         case 3:
4418             if (strEQ(d,"eof"))                 return -KEY_eof;
4419             if (strEQ(d,"exp"))                 return -KEY_exp;
4420             break;
4421         case 4:
4422             if (strEQ(d,"else"))                return KEY_else;
4423             if (strEQ(d,"exit"))                return -KEY_exit;
4424             if (strEQ(d,"eval"))                return KEY_eval;
4425             if (strEQ(d,"exec"))                return -KEY_exec;
4426             if (strEQ(d,"each"))                return KEY_each;
4427             break;
4428         case 5:
4429             if (strEQ(d,"elsif"))               return KEY_elsif;
4430             break;
4431         case 6:
4432             if (strEQ(d,"exists"))              return KEY_exists;
4433             if (strEQ(d,"elseif")) warn("elseif should be elsif");
4434             break;
4435         case 8:
4436             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
4437             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
4438             break;
4439         case 9:
4440             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
4441             break;
4442         case 10:
4443             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
4444             if (strEQ(d,"endservent"))          return -KEY_endservent;
4445             break;
4446         case 11:
4447             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
4448             break;
4449         }
4450         break;
4451     case 'f':
4452         switch (len) {
4453         case 3:
4454             if (strEQ(d,"for"))                 return KEY_for;
4455             break;
4456         case 4:
4457             if (strEQ(d,"fork"))                return -KEY_fork;
4458             break;
4459         case 5:
4460             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
4461             if (strEQ(d,"flock"))               return -KEY_flock;
4462             break;
4463         case 6:
4464             if (strEQ(d,"format"))              return KEY_format;
4465             if (strEQ(d,"fileno"))              return -KEY_fileno;
4466             break;
4467         case 7:
4468             if (strEQ(d,"foreach"))             return KEY_foreach;
4469             break;
4470         case 8:
4471             if (strEQ(d,"formline"))            return -KEY_formline;
4472             break;
4473         }
4474         break;
4475     case 'G':
4476         if (len == 2) {
4477             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
4478             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
4479         }
4480         break;
4481     case 'g':
4482         if (strnEQ(d,"get",3)) {
4483             d += 3;
4484             if (*d == 'p') {
4485                 switch (len) {
4486                 case 7:
4487                     if (strEQ(d,"ppid"))        return -KEY_getppid;
4488                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
4489                     break;
4490                 case 8:
4491                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
4492                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
4493                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
4494                     break;
4495                 case 11:
4496                     if (strEQ(d,"peername"))    return -KEY_getpeername;
4497                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
4498                     if (strEQ(d,"priority"))    return -KEY_getpriority;
4499                     break;
4500                 case 14:
4501                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4502                     break;
4503                 case 16:
4504                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4505                     break;
4506                 }
4507             }
4508             else if (*d == 'h') {
4509                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
4510                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
4511                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
4512             }
4513             else if (*d == 'n') {
4514                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
4515                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
4516                 if (strEQ(d,"netent"))          return -KEY_getnetent;
4517             }
4518             else if (*d == 's') {
4519                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
4520                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
4521                 if (strEQ(d,"servent"))         return -KEY_getservent;
4522                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
4523                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
4524             }
4525             else if (*d == 'g') {
4526                 if (strEQ(d,"grent"))           return -KEY_getgrent;
4527                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
4528                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
4529             }
4530             else if (*d == 'l') {
4531                 if (strEQ(d,"login"))           return -KEY_getlogin;
4532             }
4533             else if (strEQ(d,"c"))              return -KEY_getc;
4534             break;
4535         }
4536         switch (len) {
4537         case 2:
4538             if (strEQ(d,"gt"))                  return -KEY_gt;
4539             if (strEQ(d,"ge"))                  return -KEY_ge;
4540             break;
4541         case 4:
4542             if (strEQ(d,"grep"))                return KEY_grep;
4543             if (strEQ(d,"goto"))                return KEY_goto;
4544             if (strEQ(d,"glob"))                return KEY_glob;
4545             break;
4546         case 6:
4547             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
4548             break;
4549         }
4550         break;
4551     case 'h':
4552         if (strEQ(d,"hex"))                     return -KEY_hex;
4553         break;
4554     case 'I':
4555         if (strEQ(d,"INIT"))                    return KEY_INIT;
4556         break;
4557     case 'i':
4558         switch (len) {
4559         case 2:
4560             if (strEQ(d,"if"))                  return KEY_if;
4561             break;
4562         case 3:
4563             if (strEQ(d,"int"))                 return -KEY_int;
4564             break;
4565         case 5:
4566             if (strEQ(d,"index"))               return -KEY_index;
4567             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
4568             break;
4569         }
4570         break;
4571     case 'j':
4572         if (strEQ(d,"join"))                    return -KEY_join;
4573         break;
4574     case 'k':
4575         if (len == 4) {
4576             if (strEQ(d,"keys"))                return KEY_keys;
4577             if (strEQ(d,"kill"))                return -KEY_kill;
4578         }
4579         break;
4580     case 'L':
4581         if (len == 2) {
4582             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
4583             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
4584         }
4585         break;
4586     case 'l':
4587         switch (len) {
4588         case 2:
4589             if (strEQ(d,"lt"))                  return -KEY_lt;
4590             if (strEQ(d,"le"))                  return -KEY_le;
4591             if (strEQ(d,"lc"))                  return -KEY_lc;
4592             break;
4593         case 3:
4594             if (strEQ(d,"log"))                 return -KEY_log;
4595             break;
4596         case 4:
4597             if (strEQ(d,"last"))                return KEY_last;
4598             if (strEQ(d,"link"))                return -KEY_link;
4599             if (strEQ(d,"lock"))                return -KEY_lock;
4600             break;
4601         case 5:
4602             if (strEQ(d,"local"))               return KEY_local;
4603             if (strEQ(d,"lstat"))               return -KEY_lstat;
4604             break;
4605         case 6:
4606             if (strEQ(d,"length"))              return -KEY_length;
4607             if (strEQ(d,"listen"))              return -KEY_listen;
4608             break;
4609         case 7:
4610             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
4611             break;
4612         case 9:
4613             if (strEQ(d,"localtime"))           return -KEY_localtime;
4614             break;
4615         }
4616         break;
4617     case 'm':
4618         switch (len) {
4619         case 1:                                 return KEY_m;
4620         case 2:
4621             if (strEQ(d,"my"))                  return KEY_my;
4622             break;
4623         case 3:
4624             if (strEQ(d,"map"))                 return KEY_map;
4625             break;
4626         case 5:
4627             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
4628             break;
4629         case 6:
4630             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
4631             if (strEQ(d,"msgget"))              return -KEY_msgget;
4632             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
4633             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
4634             break;
4635         }
4636         break;
4637     case 'N':
4638         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
4639         break;
4640     case 'n':
4641         if (strEQ(d,"next"))                    return KEY_next;
4642         if (strEQ(d,"ne"))                      return -KEY_ne;
4643         if (strEQ(d,"not"))                     return -KEY_not;
4644         if (strEQ(d,"no"))                      return KEY_no;
4645         break;
4646     case 'o':
4647         switch (len) {
4648         case 2:
4649             if (strEQ(d,"or"))                  return -KEY_or;
4650             break;
4651         case 3:
4652             if (strEQ(d,"ord"))                 return -KEY_ord;
4653             if (strEQ(d,"oct"))                 return -KEY_oct;
4654             if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4655                                                 return 0;}
4656             break;
4657         case 4:
4658             if (strEQ(d,"open"))                return -KEY_open;
4659             break;
4660         case 7:
4661             if (strEQ(d,"opendir"))             return -KEY_opendir;
4662             break;
4663         }
4664         break;
4665     case 'p':
4666         switch (len) {
4667         case 3:
4668             if (strEQ(d,"pop"))                 return KEY_pop;
4669             if (strEQ(d,"pos"))                 return KEY_pos;
4670             break;
4671         case 4:
4672             if (strEQ(d,"push"))                return KEY_push;
4673             if (strEQ(d,"pack"))                return -KEY_pack;
4674             if (strEQ(d,"pipe"))                return -KEY_pipe;
4675             break;
4676         case 5:
4677             if (strEQ(d,"print"))               return KEY_print;
4678             break;
4679         case 6:
4680             if (strEQ(d,"printf"))              return KEY_printf;
4681             break;
4682         case 7:
4683             if (strEQ(d,"package"))             return KEY_package;
4684             break;
4685         case 9:
4686             if (strEQ(d,"prototype"))           return KEY_prototype;
4687         }
4688         break;
4689     case 'q':
4690         if (len <= 2) {
4691             if (strEQ(d,"q"))                   return KEY_q;
4692             if (strEQ(d,"qr"))                  return KEY_qr;
4693             if (strEQ(d,"qq"))                  return KEY_qq;
4694             if (strEQ(d,"qw"))                  return KEY_qw;
4695             if (strEQ(d,"qx"))                  return KEY_qx;
4696         }
4697         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
4698         break;
4699     case 'r':
4700         switch (len) {
4701         case 3:
4702             if (strEQ(d,"ref"))                 return -KEY_ref;
4703             break;
4704         case 4:
4705             if (strEQ(d,"read"))                return -KEY_read;
4706             if (strEQ(d,"rand"))                return -KEY_rand;
4707             if (strEQ(d,"recv"))                return -KEY_recv;
4708             if (strEQ(d,"redo"))                return KEY_redo;
4709             break;
4710         case 5:
4711             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
4712             if (strEQ(d,"reset"))               return -KEY_reset;
4713             break;
4714         case 6:
4715             if (strEQ(d,"return"))              return KEY_return;
4716             if (strEQ(d,"rename"))              return -KEY_rename;
4717             if (strEQ(d,"rindex"))              return -KEY_rindex;
4718             break;
4719         case 7:
4720             if (strEQ(d,"require"))             return -KEY_require;
4721             if (strEQ(d,"reverse"))             return -KEY_reverse;
4722             if (strEQ(d,"readdir"))             return -KEY_readdir;
4723             break;
4724         case 8:
4725             if (strEQ(d,"readlink"))            return -KEY_readlink;
4726             if (strEQ(d,"readline"))            return -KEY_readline;
4727             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
4728             break;
4729         case 9:
4730             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
4731             break;
4732         }
4733         break;
4734     case 's':
4735         switch (d[1]) {
4736         case 0:                                 return KEY_s;
4737         case 'c':
4738             if (strEQ(d,"scalar"))              return KEY_scalar;
4739             break;
4740         case 'e':
4741             switch (len) {
4742             case 4:
4743                 if (strEQ(d,"seek"))            return -KEY_seek;
4744                 if (strEQ(d,"send"))            return -KEY_send;
4745                 break;
4746             case 5:
4747                 if (strEQ(d,"semop"))           return -KEY_semop;
4748                 break;
4749             case 6:
4750                 if (strEQ(d,"select"))          return -KEY_select;
4751                 if (strEQ(d,"semctl"))          return -KEY_semctl;
4752                 if (strEQ(d,"semget"))          return -KEY_semget;
4753                 break;
4754             case 7:
4755                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
4756                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
4757                 break;
4758             case 8:
4759                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
4760                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
4761                 break;
4762             case 9:
4763                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
4764                 break;
4765             case 10:
4766                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
4767                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
4768                 if (strEQ(d,"setservent"))      return -KEY_setservent;
4769                 break;
4770             case 11:
4771                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
4772                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
4773                 break;
4774             }
4775             break;
4776         case 'h':
4777             switch (len) {
4778             case 5:
4779                 if (strEQ(d,"shift"))           return KEY_shift;
4780                 break;
4781             case 6:
4782                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
4783                 if (strEQ(d,"shmget"))          return -KEY_shmget;
4784                 break;
4785             case 7:
4786                 if (strEQ(d,"shmread"))         return -KEY_shmread;
4787                 break;
4788             case 8:
4789                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
4790                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
4791                 break;
4792             }
4793             break;
4794         case 'i':
4795             if (strEQ(d,"sin"))                 return -KEY_sin;
4796             break;
4797         case 'l':
4798             if (strEQ(d,"sleep"))               return -KEY_sleep;
4799             break;
4800         case 'o':
4801             if (strEQ(d,"sort"))                return KEY_sort;
4802             if (strEQ(d,"socket"))              return -KEY_socket;
4803             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
4804             break;
4805         case 'p':
4806             if (strEQ(d,"split"))               return KEY_split;
4807             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
4808             if (strEQ(d,"splice"))              return KEY_splice;
4809             break;
4810         case 'q':
4811             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
4812             break;
4813         case 'r':
4814             if (strEQ(d,"srand"))               return -KEY_srand;
4815             break;
4816         case 't':
4817             if (strEQ(d,"stat"))                return -KEY_stat;
4818             if (strEQ(d,"study"))               return KEY_study;
4819             break;
4820         case 'u':
4821             if (strEQ(d,"substr"))              return -KEY_substr;
4822             if (strEQ(d,"sub"))                 return KEY_sub;
4823             break;
4824         case 'y':
4825             switch (len) {
4826             case 6:
4827                 if (strEQ(d,"system"))          return -KEY_system;
4828                 break;
4829             case 7:
4830                 if (strEQ(d,"symlink"))         return -KEY_symlink;
4831                 if (strEQ(d,"syscall"))         return -KEY_syscall;
4832                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
4833                 if (strEQ(d,"sysread"))         return -KEY_sysread;
4834                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
4835                 break;
4836             case 8:
4837                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
4838                 break;
4839             }
4840             break;
4841         }
4842         break;
4843     case 't':
4844         switch (len) {
4845         case 2:
4846             if (strEQ(d,"tr"))                  return KEY_tr;
4847             break;
4848         case 3:
4849             if (strEQ(d,"tie"))                 return KEY_tie;
4850             break;
4851         case 4:
4852             if (strEQ(d,"tell"))                return -KEY_tell;
4853             if (strEQ(d,"tied"))                return KEY_tied;
4854             if (strEQ(d,"time"))                return -KEY_time;
4855             break;
4856         case 5:
4857             if (strEQ(d,"times"))               return -KEY_times;
4858             break;
4859         case 7:
4860             if (strEQ(d,"telldir"))             return -KEY_telldir;
4861             break;
4862         case 8:
4863             if (strEQ(d,"truncate"))            return -KEY_truncate;
4864             break;
4865         }
4866         break;
4867     case 'u':
4868         switch (len) {
4869         case 2:
4870             if (strEQ(d,"uc"))                  return -KEY_uc;
4871             break;
4872         case 3:
4873             if (strEQ(d,"use"))                 return KEY_use;
4874             break;
4875         case 5:
4876             if (strEQ(d,"undef"))               return KEY_undef;
4877             if (strEQ(d,"until"))               return KEY_until;
4878             if (strEQ(d,"untie"))               return KEY_untie;
4879             if (strEQ(d,"utime"))               return -KEY_utime;
4880             if (strEQ(d,"umask"))               return -KEY_umask;
4881             break;
4882         case 6:
4883             if (strEQ(d,"unless"))              return KEY_unless;
4884             if (strEQ(d,"unpack"))              return -KEY_unpack;
4885             if (strEQ(d,"unlink"))              return -KEY_unlink;
4886             break;
4887         case 7:
4888             if (strEQ(d,"unshift"))             return KEY_unshift;
4889             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
4890             break;
4891         }
4892         break;
4893     case 'v':
4894         if (strEQ(d,"values"))                  return -KEY_values;
4895         if (strEQ(d,"vec"))                     return -KEY_vec;
4896         break;
4897     case 'w':
4898         switch (len) {
4899         case 4:
4900             if (strEQ(d,"warn"))                return -KEY_warn;
4901             if (strEQ(d,"wait"))                return -KEY_wait;
4902             break;
4903         case 5:
4904             if (strEQ(d,"while"))               return KEY_while;
4905             if (strEQ(d,"write"))               return -KEY_write;
4906             break;
4907         case 7:
4908             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
4909             break;
4910         case 9:
4911             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
4912             break;
4913         }
4914         break;
4915     case 'x':
4916         if (len == 1)                           return -KEY_x;
4917         if (strEQ(d,"xor"))                     return -KEY_xor;
4918         break;
4919     case 'y':
4920         if (len == 1)                           return KEY_y;
4921         break;
4922     case 'z':
4923         break;
4924     }
4925     return 0;
4926 }
4927
4928 STATIC void
4929 checkcomma(register char *s, char *name, char *what)
4930 {
4931     char *w;
4932
4933     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
4934         dTHR;                           /* only for ckWARN */
4935         if (ckWARN(WARN_SYNTAX)) {
4936             int level = 1;
4937             for (w = s+2; *w && level; w++) {
4938                 if (*w == '(')
4939                     ++level;
4940                 else if (*w == ')')
4941                     --level;
4942             }
4943             if (*w)
4944                 for (; *w && isSPACE(*w); w++) ;
4945             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
4946                 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4947         }
4948     }
4949     while (s < PL_bufend && isSPACE(*s))
4950         s++;
4951     if (*s == '(')
4952         s++;
4953     while (s < PL_bufend && isSPACE(*s))
4954         s++;
4955     if (isIDFIRST_lazy(s)) {
4956         w = s++;
4957         while (isALNUM_lazy(s))
4958             s++;
4959         while (s < PL_bufend && isSPACE(*s))
4960             s++;
4961         if (*s == ',') {
4962             int kw;
4963             *s = '\0';
4964             kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4965             *s = ',';
4966             if (kw)
4967                 return;
4968             croak("No comma allowed after %s", what);
4969         }
4970     }
4971 }
4972
4973 STATIC SV *
4974 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4975 {
4976     dSP;
4977     HV *table = GvHV(PL_hintgv);                 /* ^H */
4978     BINOP myop;
4979     SV *res;
4980     bool oldcatch = CATCH_GET;
4981     SV **cvp;
4982     SV *cv, *typesv;
4983
4984     if (!table) {
4985         yyerror("%^H is not defined");
4986         return sv;
4987     }
4988     cvp = hv_fetch(table, key, strlen(key), FALSE);
4989     if (!cvp || !SvOK(*cvp)) {
4990         char buf[128];
4991         sprintf(buf,"$^H{%s} is not defined", key);
4992         yyerror(buf);
4993         return sv;
4994     }
4995     sv_2mortal(sv);                     /* Parent created it permanently */
4996     cv = *cvp;
4997     if (!pv)
4998         pv = sv_2mortal(newSVpvn(s, len));
4999     if (type)
5000         typesv = sv_2mortal(newSVpv(type, 0));
5001     else
5002         typesv = &PL_sv_undef;
5003     CATCH_SET(TRUE);
5004     Zero(&myop, 1, BINOP);
5005     myop.op_last = (OP *) &myop;
5006     myop.op_next = Nullop;
5007     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
5008
5009     PUSHSTACKi(PERLSI_OVERLOAD);
5010     ENTER;
5011     SAVEOP();
5012     PL_op = (OP *) &myop;
5013     if (PERLDB_SUB && PL_curstash != PL_debstash)
5014         PL_op->op_private |= OPpENTERSUB_DB;
5015     PUTBACK;
5016     pp_pushmark(ARGS);
5017
5018     EXTEND(sp, 4);
5019     PUSHs(pv);
5020     PUSHs(sv);
5021     PUSHs(typesv);
5022     PUSHs(cv);
5023     PUTBACK;
5024
5025     if (PL_op = pp_entersub(ARGS))
5026       CALLRUNOPS();
5027     LEAVE;
5028     SPAGAIN;
5029
5030     res = POPs;
5031     PUTBACK;
5032     CATCH_SET(oldcatch);
5033     POPSTACK;
5034
5035     if (!SvOK(res)) {
5036         char buf[128];
5037         sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5038         yyerror(buf);
5039     }
5040     return SvREFCNT_inc(res);
5041 }
5042
5043 STATIC char *
5044 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5045 {
5046     register char *d = dest;
5047     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
5048     for (;;) {
5049         if (d >= e)
5050             croak(ident_too_long);
5051         if (isALNUM(*s))        /* UTF handled below */
5052             *d++ = *s++;
5053         else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5054             *d++ = ':';
5055             *d++ = ':';
5056             s++;
5057         }
5058         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5059             *d++ = *s++;
5060             *d++ = *s++;
5061         }
5062         else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5063             char *t = s + UTF8SKIP(s);
5064             while (*t & 0x80 && is_utf8_mark((U8*)t))
5065                 t += UTF8SKIP(t);
5066             if (d + (t - s) > e)
5067                 croak(ident_too_long);
5068             Copy(s, d, t - s, char);
5069             d += t - s;
5070             s = t;
5071         }
5072         else {
5073             *d = '\0';
5074             *slp = d - dest;
5075             return s;
5076         }
5077     }
5078 }
5079
5080 STATIC char *
5081 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5082 {
5083     register char *d;
5084     register char *e;
5085     char *bracket = 0;
5086     char funny = *s++;
5087
5088     if (PL_lex_brackets == 0)
5089         PL_lex_fakebrack = 0;
5090     if (isSPACE(*s))
5091         s = skipspace(s);
5092     d = dest;
5093     e = d + destlen - 3;        /* two-character token, ending NUL */
5094     if (isDIGIT(*s)) {
5095         while (isDIGIT(*s)) {
5096             if (d >= e)
5097                 croak(ident_too_long);
5098             *d++ = *s++;
5099         }
5100     }
5101     else {
5102         for (;;) {
5103             if (d >= e)
5104                 croak(ident_too_long);
5105             if (isALNUM(*s))    /* UTF handled below */
5106                 *d++ = *s++;
5107             else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5108                 *d++ = ':';
5109                 *d++ = ':';
5110                 s++;
5111             }
5112             else if (*s == ':' && s[1] == ':') {
5113                 *d++ = *s++;
5114                 *d++ = *s++;
5115             }
5116             else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5117                 char *t = s + UTF8SKIP(s);
5118                 while (*t & 0x80 && is_utf8_mark((U8*)t))
5119                     t += UTF8SKIP(t);
5120                 if (d + (t - s) > e)
5121                     croak(ident_too_long);
5122                 Copy(s, d, t - s, char);
5123                 d += t - s;
5124                 s = t;
5125             }
5126             else
5127                 break;
5128         }
5129     }
5130     *d = '\0';
5131     d = dest;
5132     if (*d) {
5133         if (PL_lex_state != LEX_NORMAL)
5134             PL_lex_state = LEX_INTERPENDMAYBE;
5135         return s;
5136     }
5137     if (*s == '$' && s[1] &&
5138         (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5139     {
5140         return s;
5141     }
5142     if (*s == '{') {
5143         bracket = s;
5144         s++;
5145     }
5146     else if (ck_uni)
5147         check_uni();
5148     if (s < send)
5149         *d = *s++;
5150     d[1] = '\0';
5151     if (*d == '^' && *s && isCONTROLVAR(*s)) {
5152         *d = toCTRL(*s);
5153         s++;
5154     }
5155     if (bracket) {
5156         if (isSPACE(s[-1])) {
5157             while (s < send) {
5158                 char ch = *s++;
5159                 if (ch != ' ' && ch != '\t') {
5160                     *d = ch;
5161                     break;
5162                 }
5163             }
5164         }
5165         if (isIDFIRST_lazy(d)) {
5166             d++;
5167             if (UTF) {
5168                 e = s;
5169                 while (e < send && isALNUM_lazy(e) || *e == ':') {
5170                     e += UTF8SKIP(e);
5171                     while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5172                         e += UTF8SKIP(e);
5173                 }
5174                 Copy(s, d, e - s, char);
5175                 d += e - s;
5176                 s = e;
5177             }
5178             else {
5179                 while ((isALNUM(*s) || *s == ':') && d < e)
5180                     *d++ = *s++;
5181                 if (d >= e)
5182                     croak(ident_too_long);
5183             }
5184             *d = '\0';
5185             while (s < send && (*s == ' ' || *s == '\t')) s++;
5186             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5187                 dTHR;                   /* only for ckWARN */
5188                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5189                     char *brack = *s == '[' ? "[...]" : "{...}";
5190                     warner(WARN_AMBIGUOUS,
5191                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5192                         funny, dest, brack, funny, dest, brack);
5193                 }
5194                 PL_lex_fakebrack = PL_lex_brackets+1;
5195                 bracket++;
5196                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5197                 return s;
5198             }
5199         }
5200         /* Handle extended ${^Foo} variables
5201          * 1999-02-27 mjd-perl-patch@plover.com */
5202         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5203                  && isALNUM(*s))
5204         {
5205             d++;
5206             while (isALNUM(*s) && d < e) {
5207                 *d++ = *s++;
5208             }
5209             if (d >= e)
5210                 croak(ident_too_long);
5211             *d = '\0';
5212         }
5213         if (*s == '}') {
5214             s++;
5215             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5216                 PL_lex_state = LEX_INTERPEND;
5217             if (funny == '#')
5218                 funny = '@';
5219             if (PL_lex_state == LEX_NORMAL) {
5220                 dTHR;                   /* only for ckWARN */
5221                 if (ckWARN(WARN_AMBIGUOUS) &&
5222                     (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5223                 {
5224                     warner(WARN_AMBIGUOUS,
5225                         "Ambiguous use of %c{%s} resolved to %c%s",
5226                         funny, dest, funny, dest);
5227                 }
5228             }
5229         }
5230         else {
5231             s = bracket;                /* let the parser handle it */
5232             *dest = '\0';
5233         }
5234     }
5235     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5236         PL_lex_state = LEX_INTERPEND;
5237     return s;
5238 }
5239
5240 void pmflag(U16 *pmfl, int ch)
5241 {
5242     if (ch == 'i')
5243         *pmfl |= PMf_FOLD;
5244     else if (ch == 'g')
5245         *pmfl |= PMf_GLOBAL;
5246     else if (ch == 'c')
5247         *pmfl |= PMf_CONTINUE;
5248     else if (ch == 'o')
5249         *pmfl |= PMf_KEEP;
5250     else if (ch == 'm')
5251         *pmfl |= PMf_MULTILINE;
5252     else if (ch == 's')
5253         *pmfl |= PMf_SINGLELINE;
5254     else if (ch == 'x')
5255         *pmfl |= PMf_EXTENDED;
5256 }
5257
5258 STATIC char *
5259 scan_pat(char *start, I32 type)
5260 {
5261     PMOP *pm;
5262     char *s;
5263
5264     s = scan_str(start);
5265     if (!s) {
5266         if (PL_lex_stuff)
5267             SvREFCNT_dec(PL_lex_stuff);
5268         PL_lex_stuff = Nullsv;
5269         croak("Search pattern not terminated");
5270     }
5271
5272     pm = (PMOP*)newPMOP(type, 0);
5273     if (PL_multi_open == '?')
5274         pm->op_pmflags |= PMf_ONCE;
5275     if(type == OP_QR) {
5276         while (*s && strchr("iomsx", *s))
5277             pmflag(&pm->op_pmflags,*s++);
5278     }
5279     else {
5280         while (*s && strchr("iogcmsx", *s))
5281             pmflag(&pm->op_pmflags,*s++);
5282     }
5283     pm->op_pmpermflags = pm->op_pmflags;
5284
5285     PL_lex_op = (OP*)pm;
5286     yylval.ival = OP_MATCH;
5287     return s;
5288 }
5289
5290 STATIC char *
5291 scan_subst(char *start)
5292 {
5293     register char *s;
5294     register PMOP *pm;
5295     I32 first_start;
5296     I32 es = 0;
5297
5298     yylval.ival = OP_NULL;
5299
5300     s = scan_str(start);
5301
5302     if (!s) {
5303         if (PL_lex_stuff)
5304             SvREFCNT_dec(PL_lex_stuff);
5305         PL_lex_stuff = Nullsv;
5306         croak("Substitution pattern not terminated");
5307     }
5308
5309     if (s[-1] == PL_multi_open)
5310         s--;
5311
5312     first_start = PL_multi_start;
5313     s = scan_str(s);
5314     if (!s) {
5315         if (PL_lex_stuff)
5316             SvREFCNT_dec(PL_lex_stuff);
5317         PL_lex_stuff = Nullsv;
5318         if (PL_lex_repl)
5319             SvREFCNT_dec(PL_lex_repl);
5320         PL_lex_repl = Nullsv;
5321         croak("Substitution replacement not terminated");
5322     }
5323     PL_multi_start = first_start;       /* so whole substitution is taken together */
5324
5325     pm = (PMOP*)newPMOP(OP_SUBST, 0);
5326     while (*s) {
5327         if (*s == 'e') {
5328             s++;
5329             es++;
5330         }
5331         else if (strchr("iogcmsx", *s))
5332             pmflag(&pm->op_pmflags,*s++);
5333         else
5334             break;
5335     }
5336
5337     if (es) {
5338         SV *repl;
5339         PL_sublex_info.super_bufptr = s;
5340         PL_sublex_info.super_bufend = PL_bufend;
5341         PL_multi_end = 0;
5342         pm->op_pmflags |= PMf_EVAL;
5343         repl = newSVpvn("",0);
5344         while (es-- > 0)
5345             sv_catpv(repl, es ? "eval " : "do ");
5346         sv_catpvn(repl, "{ ", 2);
5347         sv_catsv(repl, PL_lex_repl);
5348         sv_catpvn(repl, " };", 2);
5349         SvEVALED_on(repl);
5350         SvREFCNT_dec(PL_lex_repl);
5351         PL_lex_repl = repl;
5352     }
5353
5354     pm->op_pmpermflags = pm->op_pmflags;
5355     PL_lex_op = (OP*)pm;
5356     yylval.ival = OP_SUBST;
5357     return s;
5358 }
5359
5360 STATIC char *
5361 scan_trans(char *start)
5362 {
5363     register char* s;
5364     OP *o;
5365     short *tbl;
5366     I32 squash;
5367     I32 del;
5368     I32 complement;
5369     I32 utf8;
5370     I32 count = 0;
5371
5372     yylval.ival = OP_NULL;
5373
5374     s = scan_str(start);
5375     if (!s) {
5376         if (PL_lex_stuff)
5377             SvREFCNT_dec(PL_lex_stuff);
5378         PL_lex_stuff = Nullsv;
5379         croak("Transliteration pattern not terminated");
5380     }
5381     if (s[-1] == PL_multi_open)
5382         s--;
5383
5384     s = scan_str(s);
5385     if (!s) {
5386         if (PL_lex_stuff)
5387             SvREFCNT_dec(PL_lex_stuff);
5388         PL_lex_stuff = Nullsv;
5389         if (PL_lex_repl)
5390             SvREFCNT_dec(PL_lex_repl);
5391         PL_lex_repl = Nullsv;
5392         croak("Transliteration replacement not terminated");
5393     }
5394
5395     if (UTF) {
5396         o = newSVOP(OP_TRANS, 0, 0);
5397         utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5398     }
5399     else {
5400         New(803,tbl,256,short);
5401         o = newPVOP(OP_TRANS, 0, (char*)tbl);
5402         utf8 = 0;
5403     }
5404
5405     complement = del = squash = 0;
5406     while (strchr("cdsCU", *s)) {
5407         if (*s == 'c')
5408             complement = OPpTRANS_COMPLEMENT;
5409         else if (*s == 'd')
5410             del = OPpTRANS_DELETE;
5411         else if (*s == 's')
5412             squash = OPpTRANS_SQUASH;
5413         else {
5414             switch (count++) {
5415             case 0:
5416                 if (*s == 'C')
5417                     utf8 &= ~OPpTRANS_FROM_UTF;
5418                 else
5419                     utf8 |= OPpTRANS_FROM_UTF;
5420                 break;
5421             case 1:
5422                 if (*s == 'C')
5423                     utf8 &= ~OPpTRANS_TO_UTF;
5424                 else
5425                     utf8 |= OPpTRANS_TO_UTF;
5426                 break;
5427             default:
5428                 croak("Too many /C and /U options");
5429             }
5430         }
5431         s++;
5432     }
5433     o->op_private = del|squash|complement|utf8;
5434
5435     PL_lex_op = o;
5436     yylval.ival = OP_TRANS;
5437     return s;
5438 }
5439
5440 STATIC char *
5441 scan_heredoc(register char *s)
5442 {
5443     dTHR;
5444     SV *herewas;
5445     I32 op_type = OP_SCALAR;
5446     I32 len;
5447     SV *tmpstr;
5448     char term;
5449     register char *d;
5450     register char *e;
5451     char *peek;
5452     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5453
5454     s += 2;
5455     d = PL_tokenbuf;
5456     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5457     if (!outer)
5458         *d++ = '\n';
5459     for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5460     if (*peek && strchr("`'\"",*peek)) {
5461         s = peek;
5462         term = *s++;
5463         s = delimcpy(d, e, s, PL_bufend, term, &len);
5464         d += len;
5465         if (s < PL_bufend)
5466             s++;
5467     }
5468     else {
5469         if (*s == '\\')
5470             s++, term = '\'';
5471         else
5472             term = '"';
5473         if (!isALNUM_lazy(s))
5474             deprecate("bare << to mean <<\"\"");
5475         for (; isALNUM_lazy(s); s++) {
5476             if (d < e)
5477                 *d++ = *s;
5478         }
5479     }
5480     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5481         croak("Delimiter for here document is too long");
5482     *d++ = '\n';
5483     *d = '\0';
5484     len = d - PL_tokenbuf;
5485 #ifndef PERL_STRICT_CR
5486     d = strchr(s, '\r');
5487     if (d) {
5488         char *olds = s;
5489         s = d;
5490         while (s < PL_bufend) {
5491             if (*s == '\r') {
5492                 *d++ = '\n';
5493                 if (*++s == '\n')
5494                     s++;
5495             }
5496             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
5497                 *d++ = *s++;
5498                 s++;
5499             }
5500             else
5501                 *d++ = *s++;
5502         }
5503         *d = '\0';
5504         PL_bufend = d;
5505         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5506         s = olds;
5507     }
5508 #endif
5509     d = "\n";
5510     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5511         herewas = newSVpvn(s,PL_bufend-s);
5512     else
5513         s--, herewas = newSVpvn(s,d-s);
5514     s += SvCUR(herewas);
5515
5516     tmpstr = NEWSV(87,79);
5517     sv_upgrade(tmpstr, SVt_PVIV);
5518     if (term == '\'') {
5519         op_type = OP_CONST;
5520         SvIVX(tmpstr) = -1;
5521     }
5522     else if (term == '`') {
5523         op_type = OP_BACKTICK;
5524         SvIVX(tmpstr) = '\\';
5525     }
5526
5527     CLINE;
5528     PL_multi_start = PL_curcop->cop_line;
5529     PL_multi_open = PL_multi_close = '<';
5530     term = *PL_tokenbuf;
5531     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5532         char *bufptr = PL_sublex_info.super_bufptr;
5533         char *bufend = PL_sublex_info.super_bufend;
5534         char *olds = s - SvCUR(herewas);
5535         s = strchr(bufptr, '\n');
5536         if (!s)
5537             s = bufend;
5538         d = s;
5539         while (s < bufend &&
5540           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5541             if (*s++ == '\n')
5542                 PL_curcop->cop_line++;
5543         }
5544         if (s >= bufend) {
5545             PL_curcop->cop_line = PL_multi_start;
5546             missingterm(PL_tokenbuf);
5547         }
5548         sv_setpvn(herewas,bufptr,d-bufptr+1);
5549         sv_setpvn(tmpstr,d+1,s-d);
5550         s += len - 1;
5551         sv_catpvn(herewas,s,bufend-s);
5552         (void)strcpy(bufptr,SvPVX(herewas));
5553
5554         s = olds;
5555         goto retval;
5556     }
5557     else if (!outer) {
5558         d = s;
5559         while (s < PL_bufend &&
5560           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5561             if (*s++ == '\n')
5562                 PL_curcop->cop_line++;
5563         }
5564         if (s >= PL_bufend) {
5565             PL_curcop->cop_line = PL_multi_start;
5566             missingterm(PL_tokenbuf);
5567         }
5568         sv_setpvn(tmpstr,d+1,s-d);
5569         s += len - 1;
5570         PL_curcop->cop_line++;  /* the preceding stmt passes a newline */
5571
5572         sv_catpvn(herewas,s,PL_bufend-s);
5573         sv_setsv(PL_linestr,herewas);
5574         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5575         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5576     }
5577     else
5578         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
5579     while (s >= PL_bufend) {    /* multiple line string? */
5580         if (!outer ||
5581          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5582             PL_curcop->cop_line = PL_multi_start;
5583             missingterm(PL_tokenbuf);
5584         }
5585         PL_curcop->cop_line++;
5586         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5587 #ifndef PERL_STRICT_CR
5588         if (PL_bufend - PL_linestart >= 2) {
5589             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5590                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5591             {
5592                 PL_bufend[-2] = '\n';
5593                 PL_bufend--;
5594                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5595             }
5596             else if (PL_bufend[-1] == '\r')
5597                 PL_bufend[-1] = '\n';
5598         }
5599         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5600             PL_bufend[-1] = '\n';
5601 #endif
5602         if (PERLDB_LINE && PL_curstash != PL_debstash) {
5603             SV *sv = NEWSV(88,0);
5604
5605             sv_upgrade(sv, SVt_PVMG);
5606             sv_setsv(sv,PL_linestr);
5607             av_store(GvAV(PL_curcop->cop_filegv),
5608               (I32)PL_curcop->cop_line,sv);
5609         }
5610         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5611             s = PL_bufend - 1;
5612             *s = ' ';
5613             sv_catsv(PL_linestr,herewas);
5614             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5615         }
5616         else {
5617             s = PL_bufend;
5618             sv_catsv(tmpstr,PL_linestr);
5619         }
5620     }
5621     s++;
5622 retval:
5623     PL_multi_end = PL_curcop->cop_line;
5624     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5625         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5626         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5627     }
5628     SvREFCNT_dec(herewas);
5629     PL_lex_stuff = tmpstr;
5630     yylval.ival = op_type;
5631     return s;
5632 }
5633
5634 /* scan_inputsymbol
5635    takes: current position in input buffer
5636    returns: new position in input buffer
5637    side-effects: yylval and lex_op are set.
5638
5639    This code handles:
5640
5641    <>           read from ARGV
5642    <FH>         read from filehandle
5643    <pkg::FH>    read from package qualified filehandle
5644    <pkg'FH>     read from package qualified filehandle
5645    <$fh>        read from filehandle in $fh
5646    <*.h>        filename glob
5647
5648 */
5649
5650 STATIC char *
5651 scan_inputsymbol(char *start)
5652 {
5653     register char *s = start;           /* current position in buffer */
5654     register char *d;
5655     register char *e;
5656     char *end;
5657     I32 len;
5658
5659     d = PL_tokenbuf;                    /* start of temp holding space */
5660     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
5661     end = strchr(s, '\n');
5662     if (!end)
5663         end = PL_bufend;
5664     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
5665
5666     /* die if we didn't have space for the contents of the <>,
5667        or if it didn't end, or if we see a newline
5668     */
5669
5670     if (len >= sizeof PL_tokenbuf)
5671         croak("Excessively long <> operator");
5672     if (s >= end)
5673         croak("Unterminated <> operator");
5674
5675     s++;
5676
5677     /* check for <$fh>
5678        Remember, only scalar variables are interpreted as filehandles by
5679        this code.  Anything more complex (e.g., <$fh{$num}>) will be
5680        treated as a glob() call.
5681        This code makes use of the fact that except for the $ at the front,
5682        a scalar variable and a filehandle look the same.
5683     */
5684     if (*d == '$' && d[1]) d++;
5685
5686     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5687     while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5688         d++;
5689
5690     /* If we've tried to read what we allow filehandles to look like, and
5691        there's still text left, then it must be a glob() and not a getline.
5692        Use scan_str to pull out the stuff between the <> and treat it
5693        as nothing more than a string.
5694     */
5695
5696     if (d - PL_tokenbuf != len) {
5697         yylval.ival = OP_GLOB;
5698         set_csh();
5699         s = scan_str(start);
5700         if (!s)
5701            croak("Glob not terminated");
5702         return s;
5703     }
5704     else {
5705         /* we're in a filehandle read situation */
5706         d = PL_tokenbuf;
5707
5708         /* turn <> into <ARGV> */
5709         if (!len)
5710             (void)strcpy(d,"ARGV");
5711
5712         /* if <$fh>, create the ops to turn the variable into a
5713            filehandle
5714         */
5715         if (*d == '$') {
5716             I32 tmp;
5717
5718             /* try to find it in the pad for this block, otherwise find
5719                add symbol table ops
5720             */
5721             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5722                 OP *o = newOP(OP_PADSV, 0);
5723                 o->op_targ = tmp;
5724                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5725             }
5726             else {
5727                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5728                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5729                                             newUNOP(OP_RV2SV, 0,
5730                                                 newGVOP(OP_GV, 0, gv)));
5731             }
5732             PL_lex_op->op_flags |= OPf_SPECIAL;
5733             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5734             yylval.ival = OP_NULL;
5735         }
5736
5737         /* If it's none of the above, it must be a literal filehandle
5738            (<Foo::BAR> or <FOO>) so build a simple readline OP */
5739         else {
5740             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5741             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5742             yylval.ival = OP_NULL;
5743         }
5744     }
5745
5746     return s;
5747 }
5748
5749
5750 /* scan_str
5751    takes: start position in buffer
5752    returns: position to continue reading from buffer
5753    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5754         updates the read buffer.
5755
5756    This subroutine pulls a string out of the input.  It is called for:
5757         q               single quotes           q(literal text)
5758         '               single quotes           'literal text'
5759         qq              double quotes           qq(interpolate $here please)
5760         "               double quotes           "interpolate $here please"
5761         qx              backticks               qx(/bin/ls -l)
5762         `               backticks               `/bin/ls -l`
5763         qw              quote words             @EXPORT_OK = qw( func() $spam )
5764         m//             regexp match            m/this/
5765         s///            regexp substitute       s/this/that/
5766         tr///           string transliterate    tr/this/that/
5767         y///            string transliterate    y/this/that/
5768         ($*@)           sub prototypes          sub foo ($)
5769         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
5770
5771    In most of these cases (all but <>, patterns and transliterate)
5772    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
5773    calls scan_str().  s/// makes yylex() call scan_subst() which calls
5774    scan_str().  tr/// and y/// make yylex() call scan_trans() which
5775    calls scan_str().
5776
5777    It skips whitespace before the string starts, and treats the first
5778    character as the delimiter.  If the delimiter is one of ([{< then
5779    the corresponding "close" character )]}> is used as the closing
5780    delimiter.  It allows quoting of delimiters, and if the string has
5781    balanced delimiters ([{<>}]) it allows nesting.
5782
5783    The lexer always reads these strings into lex_stuff, except in the
5784    case of the operators which take *two* arguments (s/// and tr///)
5785    when it checks to see if lex_stuff is full (presumably with the 1st
5786    arg to s or tr) and if so puts the string into lex_repl.
5787
5788 */
5789
5790 STATIC char *
5791 scan_str(char *start)
5792 {
5793     dTHR;
5794     SV *sv;                             /* scalar value: string */
5795     char *tmps;                         /* temp string, used for delimiter matching */
5796     register char *s = start;           /* current position in the buffer */
5797     register char term;                 /* terminating character */
5798     register char *to;                  /* current position in the sv's data */
5799     I32 brackets = 1;                   /* bracket nesting level */
5800
5801     /* skip space before the delimiter */
5802     if (isSPACE(*s))
5803         s = skipspace(s);
5804
5805     /* mark where we are, in case we need to report errors */
5806     CLINE;
5807
5808     /* after skipping whitespace, the next character is the terminator */
5809     term = *s;
5810     /* mark where we are */
5811     PL_multi_start = PL_curcop->cop_line;
5812     PL_multi_open = term;
5813
5814     /* find corresponding closing delimiter */
5815     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5816         term = tmps[5];
5817     PL_multi_close = term;
5818
5819     /* create a new SV to hold the contents.  87 is leak category, I'm
5820        assuming.  79 is the SV's initial length.  What a random number. */
5821     sv = NEWSV(87,79);
5822     sv_upgrade(sv, SVt_PVIV);
5823     SvIVX(sv) = term;
5824     (void)SvPOK_only(sv);               /* validate pointer */
5825
5826     /* move past delimiter and try to read a complete string */
5827     s++;
5828     for (;;) {
5829         /* extend sv if need be */
5830         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5831         /* set 'to' to the next character in the sv's string */
5832         to = SvPVX(sv)+SvCUR(sv);
5833
5834         /* if open delimiter is the close delimiter read unbridle */
5835         if (PL_multi_open == PL_multi_close) {
5836             for (; s < PL_bufend; s++,to++) {
5837                 /* embedded newlines increment the current line number */
5838                 if (*s == '\n' && !PL_rsfp)
5839                     PL_curcop->cop_line++;
5840                 /* handle quoted delimiters */
5841                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5842                     if (s[1] == term)
5843                         s++;
5844                 /* any other quotes are simply copied straight through */
5845                     else
5846                         *to++ = *s++;
5847                 }
5848                 /* terminate when run out of buffer (the for() condition), or
5849                    have found the terminator */
5850                 else if (*s == term)
5851                     break;
5852                 *to = *s;
5853             }
5854         }
5855
5856         /* if the terminator isn't the same as the start character (e.g.,
5857            matched brackets), we have to allow more in the quoting, and
5858            be prepared for nested brackets.
5859         */
5860         else {
5861             /* read until we run out of string, or we find the terminator */
5862             for (; s < PL_bufend; s++,to++) {
5863                 /* embedded newlines increment the line count */
5864                 if (*s == '\n' && !PL_rsfp)
5865                     PL_curcop->cop_line++;
5866                 /* backslashes can escape the open or closing characters */
5867                 if (*s == '\\' && s+1 < PL_bufend) {
5868                     if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5869                         s++;
5870                     else
5871                         *to++ = *s++;
5872                 }
5873                 /* allow nested opens and closes */
5874                 else if (*s == PL_multi_close && --brackets <= 0)
5875                     break;
5876                 else if (*s == PL_multi_open)
5877                     brackets++;
5878                 *to = *s;
5879             }
5880         }
5881         /* terminate the copied string and update the sv's end-of-string */
5882         *to = '\0';
5883         SvCUR_set(sv, to - SvPVX(sv));
5884
5885         /*
5886          * this next chunk reads more into the buffer if we're not done yet
5887          */
5888
5889         if (s < PL_bufend) break;       /* handle case where we are done yet :-) */
5890
5891 #ifndef PERL_STRICT_CR
5892         if (to - SvPVX(sv) >= 2) {
5893             if ((to[-2] == '\r' && to[-1] == '\n') ||
5894                 (to[-2] == '\n' && to[-1] == '\r'))
5895             {
5896                 to[-2] = '\n';
5897                 to--;
5898                 SvCUR_set(sv, to - SvPVX(sv));
5899             }
5900             else if (to[-1] == '\r')
5901                 to[-1] = '\n';
5902         }
5903         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5904             to[-1] = '\n';
5905 #endif
5906
5907         /* if we're out of file, or a read fails, bail and reset the current
5908            line marker so we can report where the unterminated string began
5909         */
5910         if (!PL_rsfp ||
5911          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5912             sv_free(sv);
5913             PL_curcop->cop_line = PL_multi_start;
5914             return Nullch;
5915         }
5916         /* we read a line, so increment our line counter */
5917         PL_curcop->cop_line++;
5918
5919         /* update debugger info */
5920         if (PERLDB_LINE && PL_curstash != PL_debstash) {
5921             SV *sv = NEWSV(88,0);
5922
5923             sv_upgrade(sv, SVt_PVMG);
5924             sv_setsv(sv,PL_linestr);
5925             av_store(GvAV(PL_curcop->cop_filegv),
5926               (I32)PL_curcop->cop_line, sv);
5927         }
5928
5929         /* having changed the buffer, we must update PL_bufend */
5930         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5931     }
5932
5933     /* at this point, we have successfully read the delimited string */
5934
5935     PL_multi_end = PL_curcop->cop_line;
5936     s++;
5937
5938     /* if we allocated too much space, give some back */
5939     if (SvCUR(sv) + 5 < SvLEN(sv)) {
5940         SvLEN_set(sv, SvCUR(sv) + 1);
5941         Renew(SvPVX(sv), SvLEN(sv), char);
5942     }
5943
5944     /* decide whether this is the first or second quoted string we've read
5945        for this op
5946     */
5947
5948     if (PL_lex_stuff)
5949         PL_lex_repl = sv;
5950     else
5951         PL_lex_stuff = sv;
5952     return s;
5953 }
5954
5955 /*
5956   scan_num
5957   takes: pointer to position in buffer
5958   returns: pointer to new position in buffer
5959   side-effects: builds ops for the constant in yylval.op
5960
5961   Read a number in any of the formats that Perl accepts:
5962
5963   0(x[0-7A-F]+)|([0-7]+)|(b[01])
5964   [\d_]+(\.[\d_]*)?[Ee](\d+)
5965
5966   Underbars (_) are allowed in decimal numbers.  If -w is on,
5967   underbars before a decimal point must be at three digit intervals.
5968
5969   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5970   thing it reads.
5971
5972   If it reads a number without a decimal point or an exponent, it will
5973   try converting the number to an integer and see if it can do so
5974   without loss of precision.
5975 */
5976
5977 char *
5978 scan_num(char *start)
5979 {
5980     register char *s = start;           /* current position in buffer */
5981     register char *d;                   /* destination in temp buffer */
5982     register char *e;                   /* end of temp buffer */
5983     I32 tryiv;                          /* used to see if it can be an int */
5984     double value;                       /* number read, as a double */
5985     SV *sv;                             /* place to put the converted number */
5986     I32 floatit;                        /* boolean: int or float? */
5987     char *lastub = 0;                   /* position of last underbar */
5988     static char number_too_long[] = "Number too long";
5989
5990     /* We use the first character to decide what type of number this is */
5991
5992     switch (*s) {
5993     default:
5994       croak("panic: scan_num");
5995
5996     /* if it starts with a 0, it could be an octal number, a decimal in
5997        0.13 disguise, or a hexadecimal number, or a binary number.
5998     */
5999     case '0':
6000         {
6001           /* variables:
6002              u          holds the "number so far"
6003              shift      the power of 2 of the base
6004                         (hex == 4, octal == 3, binary == 1)
6005              overflowed was the number more than we can hold?
6006
6007              Shift is used when we add a digit.  It also serves as an "are
6008              we in octal/hex/binary?" indicator to disallow hex characters
6009              when in octal mode.
6010            */
6011             UV u;
6012             I32 shift;
6013             bool overflowed = FALSE;
6014
6015             /* check for hex */
6016             if (s[1] == 'x') {
6017                 shift = 4;
6018                 s += 2;
6019             } else if (s[1] == 'b') {
6020                 shift = 1;
6021                 s += 2;
6022             }
6023             /* check for a decimal in disguise */
6024             else if (s[1] == '.')
6025                 goto decimal;
6026             /* so it must be octal */
6027             else
6028                 shift = 3;
6029             u = 0;
6030
6031             /* read the rest of the number */
6032             for (;;) {
6033                 UV n, b;        /* n is used in the overflow test, b is the digit we're adding on */
6034
6035                 switch (*s) {
6036
6037                 /* if we don't mention it, we're done */
6038                 default:
6039                     goto out;
6040
6041                 /* _ are ignored */
6042                 case '_':
6043                     s++;
6044                     break;
6045
6046                 /* 8 and 9 are not octal */
6047                 case '8': case '9':
6048                     if (shift == 3)
6049                         yyerror(form("Illegal octal digit '%c'", *s));
6050                     else
6051                         if (shift == 1)
6052                             yyerror(form("Illegal binary digit '%c'", *s));
6053                     /* FALL THROUGH */
6054
6055                 /* octal digits */
6056                 case '2': case '3': case '4':
6057                 case '5': case '6': case '7':
6058                     if (shift == 1)
6059                         yyerror(form("Illegal binary digit '%c'", *s));
6060                     /* FALL THROUGH */
6061
6062                 case '0': case '1':
6063                     b = *s++ & 15;              /* ASCII digit -> value of digit */
6064                     goto digit;
6065
6066                 /* hex digits */
6067                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6068                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6069                     /* make sure they said 0x */
6070                     if (shift != 4)
6071                         goto out;
6072                     b = (*s++ & 7) + 9;
6073
6074                     /* Prepare to put the digit we have onto the end
6075                        of the number so far.  We check for overflows.
6076                     */
6077
6078                   digit:
6079                     n = u << shift;     /* make room for the digit */
6080                     if (!overflowed && (n >> shift) != u
6081                         && !(PL_hints & HINT_NEW_BINARY)) {
6082                         warn("Integer overflow in %s number",
6083                              (shift == 4) ? "hex"
6084                              : ((shift == 3) ? "octal" : "binary"));
6085                         overflowed = TRUE;
6086                     }
6087                     u = n | b;          /* add the digit to the end */
6088                     break;
6089                 }
6090             }
6091
6092           /* if we get here, we had success: make a scalar value from
6093              the number.
6094           */
6095           out:
6096             sv = NEWSV(92,0);
6097             sv_setuv(sv, u);
6098             if ( PL_hints & HINT_NEW_BINARY)
6099                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6100         }
6101         break;
6102
6103     /*
6104       handle decimal numbers.
6105       we're also sent here when we read a 0 as the first digit
6106     */
6107     case '1': case '2': case '3': case '4': case '5':
6108     case '6': case '7': case '8': case '9': case '.':
6109       decimal:
6110         d = PL_tokenbuf;
6111         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6112         floatit = FALSE;
6113
6114         /* read next group of digits and _ and copy into d */
6115         while (isDIGIT(*s) || *s == '_') {
6116             /* skip underscores, checking for misplaced ones
6117                if -w is on
6118             */
6119             if (*s == '_') {
6120                 dTHR;                   /* only for ckWARN */
6121                 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6122                     warner(WARN_SYNTAX, "Misplaced _ in number");
6123                 lastub = ++s;
6124             }
6125             else {
6126                 /* check for end of fixed-length buffer */
6127                 if (d >= e)
6128                     croak(number_too_long);
6129                 /* if we're ok, copy the character */
6130                 *d++ = *s++;
6131             }
6132         }
6133
6134         /* final misplaced underbar check */
6135         if (lastub && s - lastub != 3) {
6136             dTHR;
6137             if (ckWARN(WARN_SYNTAX))
6138                 warner(WARN_SYNTAX, "Misplaced _ in number");
6139         }
6140
6141         /* read a decimal portion if there is one.  avoid
6142            3..5 being interpreted as the number 3. followed
6143            by .5
6144         */
6145         if (*s == '.' && s[1] != '.') {
6146             floatit = TRUE;
6147             *d++ = *s++;
6148
6149             /* copy, ignoring underbars, until we run out of
6150                digits.  Note: no misplaced underbar checks!
6151             */
6152             for (; isDIGIT(*s) || *s == '_'; s++) {
6153                 /* fixed length buffer check */
6154                 if (d >= e)
6155                     croak(number_too_long);
6156                 if (*s != '_')
6157                     *d++ = *s;
6158             }
6159         }
6160
6161         /* read exponent part, if present */
6162         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6163             floatit = TRUE;
6164             s++;
6165
6166             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6167             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
6168
6169             /* allow positive or negative exponent */
6170             if (*s == '+' || *s == '-')
6171                 *d++ = *s++;
6172
6173             /* read digits of exponent (no underbars :-) */
6174             while (isDIGIT(*s)) {
6175                 if (d >= e)
6176                     croak(number_too_long);
6177                 *d++ = *s++;
6178             }
6179         }
6180
6181         /* terminate the string */
6182         *d = '\0';
6183
6184         /* make an sv from the string */
6185         sv = NEWSV(92,0);
6186         /* reset numeric locale in case we were earlier left in Swaziland */
6187         SET_NUMERIC_STANDARD();
6188         value = atof(PL_tokenbuf);
6189
6190         /*
6191            See if we can make do with an integer value without loss of
6192            precision.  We use I_V to cast to an int, because some
6193            compilers have issues.  Then we try casting it back and see
6194            if it was the same.  We only do this if we know we
6195            specifically read an integer.
6196
6197            Note: if floatit is true, then we don't need to do the
6198            conversion at all.
6199         */
6200         tryiv = I_V(value);
6201         if (!floatit && (double)tryiv == value)
6202             sv_setiv(sv, tryiv);
6203         else
6204             sv_setnv(sv, value);
6205         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6206             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6207                               (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6208         break;
6209     }
6210
6211     /* make the op for the constant and return */
6212
6213     yylval.opval = newSVOP(OP_CONST, 0, sv);
6214
6215     return s;
6216 }
6217
6218 STATIC char *
6219 scan_formline(register char *s)
6220 {
6221     dTHR;
6222     register char *eol;
6223     register char *t;
6224     SV *stuff = newSVpvn("",0);
6225     bool needargs = FALSE;
6226
6227     while (!needargs) {
6228         if (*s == '.' || *s == '}') {
6229             /*SUPPRESS 530*/
6230 #ifdef PERL_STRICT_CR
6231             for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6232 #else
6233             for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6234 #endif
6235             if (*t == '\n' || t == PL_bufend)
6236                 break;
6237         }
6238         if (PL_in_eval && !PL_rsfp) {
6239             eol = strchr(s,'\n');
6240             if (!eol++)
6241                 eol = PL_bufend;
6242         }
6243         else
6244             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6245         if (*s != '#') {
6246             for (t = s; t < eol; t++) {
6247                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6248                     needargs = FALSE;
6249                     goto enough;        /* ~~ must be first line in formline */
6250                 }
6251                 if (*t == '@' || *t == '^')
6252                     needargs = TRUE;
6253             }
6254             sv_catpvn(stuff, s, eol-s);
6255         }
6256         s = eol;
6257         if (PL_rsfp) {
6258             s = filter_gets(PL_linestr, PL_rsfp, 0);
6259             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6260             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6261             if (!s) {
6262                 s = PL_bufptr;
6263                 yyerror("Format not terminated");
6264                 break;
6265             }
6266         }
6267         incline(s);
6268     }
6269   enough:
6270     if (SvCUR(stuff)) {
6271         PL_expect = XTERM;
6272         if (needargs) {
6273             PL_lex_state = LEX_NORMAL;
6274             PL_nextval[PL_nexttoke].ival = 0;
6275             force_next(',');
6276         }
6277         else
6278             PL_lex_state = LEX_FORMLINE;
6279         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6280         force_next(THING);
6281         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6282         force_next(LSTOP);
6283     }
6284     else {
6285         SvREFCNT_dec(stuff);
6286         PL_lex_formbrack = 0;
6287         PL_bufptr = s;
6288     }
6289     return s;
6290 }
6291
6292 STATIC void
6293 set_csh(void)
6294 {
6295 #ifdef CSH
6296     if (!PL_cshlen)
6297         PL_cshlen = strlen(PL_cshname);
6298 #endif
6299 }
6300
6301 I32
6302 start_subparse(I32 is_format, U32 flags)
6303 {
6304     dTHR;
6305     I32 oldsavestack_ix = PL_savestack_ix;
6306     CV* outsidecv = PL_compcv;
6307     AV* comppadlist;
6308
6309     if (PL_compcv) {
6310         assert(SvTYPE(PL_compcv) == SVt_PVCV);
6311     }
6312     save_I32(&PL_subline);
6313     save_item(PL_subname);
6314     SAVEI32(PL_padix);
6315     SAVESPTR(PL_curpad);
6316     SAVESPTR(PL_comppad);
6317     SAVESPTR(PL_comppad_name);
6318     SAVESPTR(PL_compcv);
6319     SAVEI32(PL_comppad_name_fill);
6320     SAVEI32(PL_min_intro_pending);
6321     SAVEI32(PL_max_intro_pending);
6322     SAVEI32(PL_pad_reset_pending);
6323
6324     PL_compcv = (CV*)NEWSV(1104,0);
6325     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6326     CvFLAGS(PL_compcv) |= flags;
6327
6328     PL_comppad = newAV();
6329     av_push(PL_comppad, Nullsv);
6330     PL_curpad = AvARRAY(PL_comppad);
6331     PL_comppad_name = newAV();
6332     PL_comppad_name_fill = 0;
6333     PL_min_intro_pending = 0;
6334     PL_padix = 0;
6335     PL_subline = PL_curcop->cop_line;
6336 #ifdef USE_THREADS
6337     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6338     PL_curpad[0] = (SV*)newAV();
6339     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
6340 #endif /* USE_THREADS */
6341
6342     comppadlist = newAV();
6343     AvREAL_off(comppadlist);
6344     av_store(comppadlist, 0, (SV*)PL_comppad_name);
6345     av_store(comppadlist, 1, (SV*)PL_comppad);
6346
6347     CvPADLIST(PL_compcv) = comppadlist;
6348     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6349 #ifdef USE_THREADS
6350     CvOWNER(PL_compcv) = 0;
6351     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6352     MUTEX_INIT(CvMUTEXP(PL_compcv));
6353 #endif /* USE_THREADS */
6354
6355     return oldsavestack_ix;
6356 }
6357
6358 int
6359 yywarn(char *s)
6360 {
6361     dTHR;
6362     --PL_error_count;
6363     PL_in_eval |= EVAL_WARNONLY;
6364     yyerror(s);
6365     PL_in_eval &= ~EVAL_WARNONLY;
6366     return 0;
6367 }
6368
6369 int
6370 yyerror(char *s)
6371 {
6372     dTHR;
6373     char *where = NULL;
6374     char *context = NULL;
6375     int contlen = -1;
6376     SV *msg;
6377
6378     if (!yychar || (yychar == ';' && !PL_rsfp))
6379         where = "at EOF";
6380     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6381       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6382         while (isSPACE(*PL_oldoldbufptr))
6383             PL_oldoldbufptr++;
6384         context = PL_oldoldbufptr;
6385         contlen = PL_bufptr - PL_oldoldbufptr;
6386     }
6387     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6388       PL_oldbufptr != PL_bufptr) {
6389         while (isSPACE(*PL_oldbufptr))
6390             PL_oldbufptr++;
6391         context = PL_oldbufptr;
6392         contlen = PL_bufptr - PL_oldbufptr;
6393     }
6394     else if (yychar > 255)
6395         where = "next token ???";
6396     else if ((yychar & 127) == 127) {
6397         if (PL_lex_state == LEX_NORMAL ||
6398            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6399             where = "at end of line";
6400         else if (PL_lex_inpat)
6401             where = "within pattern";
6402         else
6403             where = "within string";
6404     }
6405     else {
6406         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6407         if (yychar < 32)
6408             sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6409         else if (isPRINT_LC(yychar))
6410             sv_catpvf(where_sv, "%c", yychar);
6411         else
6412             sv_catpvf(where_sv, "\\%03o", yychar & 255);
6413         where = SvPVX(where_sv);
6414     }
6415     msg = sv_2mortal(newSVpv(s, 0));
6416     sv_catpvf(msg, " at %_ line %ld, ",
6417               GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6418     if (context)
6419         sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6420     else
6421         sv_catpvf(msg, "%s\n", where);
6422     if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6423         sv_catpvf(msg,
6424         "  (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6425                 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6426         PL_multi_end = 0;
6427     }
6428     if (PL_in_eval & EVAL_WARNONLY)
6429         warn("%_", msg);
6430     else if (PL_in_eval)
6431         sv_catsv(ERRSV, msg);
6432     else
6433         PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6434     if (++PL_error_count >= 10)
6435         croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6436     PL_in_my = 0;
6437     PL_in_my_stash = Nullhv;
6438     return 0;
6439 }
6440
6441