toke.c

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