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