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