pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * Now far ahead the Road has gone,
  13  * And I must follow, if I can,
  14  * Pursuing it with eager feet,
  15  * Until it joins some larger way
  16  * Where many paths and errands meet.
  17  * And whither then?  I cannot say.
  18  */
  19
  20 /* This file contains control-oriented pp ("push/pop") functions that
  21  * execute the opcodes that make up a perl program. A typical pp function
  22  * expects to find its arguments on the stack, and usually pushes its
  23  * results onto the stack, hence the 'pp' terminology. Each OP structure
  24  * contains a pointer to the relevant pp_foo() function.
  25  *
  26  * Control-oriented means things like pp_enteriter() and pp_next(), which
  27  * alter the flow of control of the program.
  28  */
  29
  30
  31 #include "EXTERN.h"
  32 #define PERL_IN_PP_CTL_C
  33 #include "perl.h"
  34
  35 #ifndef WORD_ALIGN
  36 #define WORD_ALIGN sizeof(U32)
  37 #endif
  38
  39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  40
  41 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
  42
  43 PP(pp_wantarray)
  44 {
  45     dVAR;
  46     dSP;
  47     I32 cxix;
  48     EXTEND(SP, 1);
  49
  50     cxix = dopoptosub(cxstack_ix);
  51     if (cxix < 0)
  52         RETPUSHUNDEF;
  53
  54     switch (cxstack[cxix].blk_gimme) {
  55     case G_ARRAY:
  56         RETPUSHYES;
  57     case G_SCALAR:
  58         RETPUSHNO;
  59     default:
  60         RETPUSHUNDEF;
  61     }
  62 }
  63
  64 PP(pp_regcreset)
  65 {
  66     dVAR;
  67     /* XXXX Should store the old value to allow for tie/overload - and
  68        restore in regcomp, where marked with XXXX. */
  69     PL_reginterp_cnt = 0;
  70     TAINT_NOT;
  71     return NORMAL;
  72 }
  73
  74 PP(pp_regcomp)
  75 {
  76     dVAR;
  77     dSP;
  78     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  79     SV *tmpstr;
  80     REGEXP *re = NULL;
  81
  82     /* prevent recompiling under /o and ithreads. */
  83 #if defined(USE_ITHREADS)
  84     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
  85         if (PL_op->op_flags & OPf_STACKED) {
  86             dMARK;
  87             SP = MARK;
  88         }
  89         else
  90             (void)POPs;
  91         RETURN;
  92     }
  93 #endif
  94     if (PL_op->op_flags & OPf_STACKED) {
  95         /* multiple args; concatentate them */
  96         dMARK; dORIGMARK;
  97         tmpstr = PAD_SV(ARGTARG);
  98         sv_setpvn(tmpstr, "", 0);
  99         while (++MARK <= SP) {
 100             if (PL_amagic_generation) {
 101                 SV *sv;
 102                 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
 103                     (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
 104                 {
 105                    sv_setsv(tmpstr, sv);
 106                    continue;
 107                 }
 108             }
 109             sv_catsv(tmpstr, *MARK);
 110         }
 111         SvSETMAGIC(tmpstr);
 112         SP = ORIGMARK;
 113     }
 114     else
 115         tmpstr = POPs;
 116
 117     if (SvROK(tmpstr)) {
 118         SV * const sv = SvRV(tmpstr);
 119         if (SvTYPE(sv) == SVt_REGEXP)
 120             re = ((struct xregexp *)SvANY(sv))->xrx_regexp;
 121     }
 122     if (re) {
 123         re = reg_temp_copy(re);
 124         ReREFCNT_dec(PM_GETRE(pm));
 125         PM_SETRE(pm, re);
 126     }
 127     else {
 128         STRLEN len;
 129         const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
 130         re = PM_GETRE(pm);
 131
 132         /* Check against the last compiled regexp. */
 133         if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != (I32)len ||
 134             memNE(RX_PRECOMP(re), t, len))
 135         {
 136             const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
 137             U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
 138             if (re) {
 139                 ReREFCNT_dec(re);
 140                 PM_SETRE(pm, NULL);     /* crucial if regcomp aborts */
 141             } else if (PL_curcop->cop_hints_hash) {
 142                 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
 143                                        "regcomp", 7, 0, 0);
 144                 if (ptr && SvIOK(ptr) && SvIV(ptr))
 145                     eng = INT2PTR(regexp_engine*,SvIV(ptr));
 146             }
 147
 148             if (PL_op->op_flags & OPf_SPECIAL)
 149                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 150
 151             if (DO_UTF8(tmpstr))
 152                 pm_flags |= RXf_UTF8;
 153
 154                 if (eng)
 155                 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
 156                 else
 157                 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
 158
 159             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 160                                            inside tie/overload accessors.  */
 161         }
 162     }
 163
 164     re = PM_GETRE(pm);
 165
 166 #ifndef INCOMPLETE_TAINTS
 167     if (PL_tainting) {
 168         if (PL_tainted)
 169             RX_EXTFLAGS(re) |= RXf_TAINTED;
 170         else
 171             RX_EXTFLAGS(re) &= ~RXf_TAINTED;
 172     }
 173 #endif
 174
 175     if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
 176         pm = PL_curpm;
 177
 178
 179 #if !defined(USE_ITHREADS)
 180     /* can't change the optree at runtime either */
 181     /* PMf_KEEP is handled differently under threads to avoid these problems */
 182     if (pm->op_pmflags & PMf_KEEP) {
 183         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 184         cLOGOP->op_first->op_next = PL_op->op_next;
 185     }
 186 #endif
 187     RETURN;
 188 }
 189
 190 PP(pp_substcont)
 191 {
 192     dVAR;
 193     dSP;
 194     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 195     register PMOP * const pm = (PMOP*) cLOGOP->op_other;
 196     register SV * const dstr = cx->sb_dstr;
 197     register char *s = cx->sb_s;
 198     register char *m = cx->sb_m;
 199     char *orig = cx->sb_orig;
 200     register REGEXP * const rx = cx->sb_rx;
 201     SV *nsv = NULL;
 202     REGEXP *old = PM_GETRE(pm);
 203     if(old != rx) {
 204         if(old)
 205             ReREFCNT_dec(old);
 206         PM_SETRE(pm,ReREFCNT_inc(rx));
 207     }
 208
 209     rxres_restore(&cx->sb_rxres, rx);
 210     RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
 211
 212     if (cx->sb_iters++) {
 213         const I32 saviters = cx->sb_iters;
 214         if (cx->sb_iters > cx->sb_maxiters)
 215             DIE(aTHX_ "Substitution loop");
 216
 217         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 218             cx->sb_rxtainted |= 2;
 219         sv_catsv(dstr, POPs);
 220         FREETMPS; /* Prevent excess tmp stack */
 221
 222         /* Are we done */
 223         if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 224                                      s == m, cx->sb_targ, NULL,
 225                                      ((cx->sb_rflags & REXEC_COPY_STR)
 226                                       ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 227                                       : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 228         {
 229             SV * const targ = cx->sb_targ;
 230
 231             assert(cx->sb_strend >= s);
 232             if(cx->sb_strend > s) {
 233                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 234                       sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 235                  else
 236                       sv_catpvn(dstr, s, cx->sb_strend - s);
 237             }
 238             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 239
 240 #ifdef PERL_OLD_COPY_ON_WRITE
 241             if (SvIsCOW(targ)) {
 242                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 243             } else
 244 #endif
 245             {
 246                 SvPV_free(targ);
 247             }
 248             SvPV_set(targ, SvPVX(dstr));
 249             SvCUR_set(targ, SvCUR(dstr));
 250             SvLEN_set(targ, SvLEN(dstr));
 251             if (DO_UTF8(dstr))
 252                 SvUTF8_on(targ);
 253             SvPV_set(dstr, NULL);
 254
 255             TAINT_IF(cx->sb_rxtainted & 1);
 256             PUSHs(sv_2mortal(newSViv(saviters - 1)));
 257
 258             (void)SvPOK_only_UTF8(targ);
 259             TAINT_IF(cx->sb_rxtainted);
 260             SvSETMAGIC(targ);
 261             SvTAINT(targ);
 262
 263             LEAVE_SCOPE(cx->sb_oldsave);
 264             POPSUBST(cx);
 265             RETURNOP(pm->op_next);
 266         }
 267         cx->sb_iters = saviters;
 268     }
 269     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 270         m = s;
 271         s = orig;
 272         cx->sb_orig = orig = RX_SUBBEG(rx);
 273         s = orig + (m - s);
 274         cx->sb_strend = s + (cx->sb_strend - m);
 275     }
 276     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
 277     if (m > s) {
 278         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 279             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
 280         else
 281             sv_catpvn(dstr, s, m-s);
 282     }
 283     cx->sb_s = RX_OFFS(rx)[0].end + orig;
 284     { /* Update the pos() information. */
 285         SV * const sv = cx->sb_targ;
 286         MAGIC *mg;
 287         I32 i;
 288         SvUPGRADE(sv, SVt_PVMG);
 289         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 290 #ifdef PERL_OLD_COPY_ON_WRITE
 291             if (SvIsCOW(sv))
 292                 sv_force_normal_flags(sv, 0);
 293 #endif
 294             mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
 295                              NULL, 0);
 296         }
 297         i = m - orig;
 298         if (DO_UTF8(sv))
 299             sv_pos_b2u(sv, &i);
 300         mg->mg_len = i;
 301     }
 302     if (old != rx)
 303         (void)ReREFCNT_inc(rx);
 304     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 305     rxres_save(&cx->sb_rxres, rx);
 306     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 307 }
 308
 309 void
 310 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 311 {
 312     UV *p = (UV*)*rsp;
 313     U32 i;
 314     PERL_UNUSED_CONTEXT;
 315
 316     if (!p || p[1] < RX_NPARENS(rx)) {
 317 #ifdef PERL_OLD_COPY_ON_WRITE
 318         i = 7 + RX_NPARENS(rx) * 2;
 319 #else
 320         i = 6 + RX_NPARENS(rx) * 2;
 321 #endif
 322         if (!p)
 323             Newx(p, i, UV);
 324         else
 325             Renew(p, i, UV);
 326         *rsp = (void*)p;
 327     }
 328
 329     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
 330     RX_MATCH_COPIED_off(rx);
 331
 332 #ifdef PERL_OLD_COPY_ON_WRITE
 333     *p++ = PTR2UV(rx->saved_copy);
 334     rx->saved_copy = NULL;
 335 #endif
 336
 337     *p++ = RX_NPARENS(rx);
 338
 339     *p++ = PTR2UV(RX_SUBBEG(rx));
 340     *p++ = (UV)RX_SUBLEN(rx);
 341     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 342         *p++ = (UV)RX_OFFS(rx)[i].start;
 343         *p++ = (UV)RX_OFFS(rx)[i].end;
 344     }
 345 }
 346
 347 void
 348 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 349 {
 350     UV *p = (UV*)*rsp;
 351     U32 i;
 352     PERL_UNUSED_CONTEXT;
 353
 354     RX_MATCH_COPY_FREE(rx);
 355     RX_MATCH_COPIED_set(rx, *p);
 356     *p++ = 0;
 357
 358 #ifdef PERL_OLD_COPY_ON_WRITE
 359     if (rx->saved_copy)
 360         SvREFCNT_dec (rx->saved_copy);
 361     rx->saved_copy = INT2PTR(SV*,*p);
 362     *p++ = 0;
 363 #endif
 364
 365     RX_NPARENS(rx) = *p++;
 366
 367     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
 368     RX_SUBLEN(rx) = (I32)(*p++);
 369     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 370         RX_OFFS(rx)[i].start = (I32)(*p++);
 371         RX_OFFS(rx)[i].end = (I32)(*p++);
 372     }
 373 }
 374
 375 void
 376 Perl_rxres_free(pTHX_ void **rsp)
 377 {
 378     UV * const p = (UV*)*rsp;
 379     PERL_UNUSED_CONTEXT;
 380
 381     if (p) {
 382 #ifdef PERL_POISON
 383         void *tmp = INT2PTR(char*,*p);
 384         Safefree(tmp);
 385         if (*p)
 386             PoisonFree(*p, 1, sizeof(*p));
 387 #else
 388         Safefree(INT2PTR(char*,*p));
 389 #endif
 390 #ifdef PERL_OLD_COPY_ON_WRITE
 391         if (p[1]) {
 392             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 393         }
 394 #endif
 395         Safefree(p);
 396         *rsp = NULL;
 397     }
 398 }
 399
 400 PP(pp_formline)
 401 {
 402     dVAR; dSP; dMARK; dORIGMARK;
 403     register SV * const tmpForm = *++MARK;
 404     register U32 *fpc;
 405     register char *t;
 406     const char *f;
 407     register I32 arg;
 408     register SV *sv = NULL;
 409     const char *item = NULL;
 410     I32 itemsize  = 0;
 411     I32 fieldsize = 0;
 412     I32 lines = 0;
 413     bool chopspace = (strchr(PL_chopset, ' ') != NULL);
 414     const char *chophere = NULL;
 415     char *linemark = NULL;
 416     NV value;
 417     bool gotsome = FALSE;
 418     STRLEN len;
 419     const STRLEN fudge = SvPOK(tmpForm)
 420                         ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
 421     bool item_is_utf8 = FALSE;
 422     bool targ_is_utf8 = FALSE;
 423     SV * nsv = NULL;
 424     OP * parseres = NULL;
 425     const char *fmt;
 426     bool oneline;
 427
 428     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 429         if (SvREADONLY(tmpForm)) {
 430             SvREADONLY_off(tmpForm);
 431             parseres = doparseform(tmpForm);
 432             SvREADONLY_on(tmpForm);
 433         }
 434         else
 435             parseres = doparseform(tmpForm);
 436         if (parseres)
 437             return parseres;
 438     }
 439     SvPV_force(PL_formtarget, len);
 440     if (DO_UTF8(PL_formtarget))
 441         targ_is_utf8 = TRUE;
 442     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 443     t += len;
 444     f = SvPV_const(tmpForm, len);
 445     /* need to jump to the next word */
 446     fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
 447
 448     for (;;) {
 449         DEBUG_f( {
 450             const char *name = "???";
 451             arg = -1;
 452             switch (*fpc) {
 453             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 454             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 455             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 456             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 457             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 458
 459             case FF_CHECKNL:    name = "CHECKNL";       break;
 460             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 461             case FF_SPACE:      name = "SPACE";         break;
 462             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 463             case FF_ITEM:       name = "ITEM";          break;
 464             case FF_CHOP:       name = "CHOP";          break;
 465             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 466             case FF_NEWLINE:    name = "NEWLINE";       break;
 467             case FF_MORE:       name = "MORE";          break;
 468             case FF_LINEMARK:   name = "LINEMARK";      break;
 469             case FF_END:        name = "END";           break;
 470             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 471             case FF_LINESNGL:   name = "LINESNGL";      break;
 472             }
 473             if (arg >= 0)
 474                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 475             else
 476                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 477         } );
 478         switch (*fpc++) {
 479         case FF_LINEMARK:
 480             linemark = t;
 481             lines++;
 482             gotsome = FALSE;
 483             break;
 484
 485         case FF_LITERAL:
 486             arg = *fpc++;
 487             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
 488                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 489                 *t = '\0';
 490                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
 491                 t = SvEND(PL_formtarget);
 492                 break;
 493             }
 494             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 495                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 496                 *t = '\0';
 497                 sv_utf8_upgrade(PL_formtarget);
 498                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 499                 t = SvEND(PL_formtarget);
 500                 targ_is_utf8 = TRUE;
 501             }
 502             while (arg--)
 503                 *t++ = *f++;
 504             break;
 505
 506         case FF_SKIP:
 507             f += *fpc++;
 508             break;
 509
 510         case FF_FETCH:
 511             arg = *fpc++;
 512             f += arg;
 513             fieldsize = arg;
 514
 515             if (MARK < SP)
 516                 sv = *++MARK;
 517             else {
 518                 sv = &PL_sv_no;
 519                 if (ckWARN(WARN_SYNTAX))
 520                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 521             }
 522             break;
 523
 524         case FF_CHECKNL:
 525             {
 526                 const char *send;
 527                 const char *s = item = SvPV_const(sv, len);
 528                 itemsize = len;
 529                 if (DO_UTF8(sv)) {
 530                     itemsize = sv_len_utf8(sv);
 531                     if (itemsize != (I32)len) {
 532                         I32 itembytes;
 533                         if (itemsize > fieldsize) {
 534                             itemsize = fieldsize;
 535                             itembytes = itemsize;
 536                             sv_pos_u2b(sv, &itembytes, 0);
 537                         }
 538                         else
 539                             itembytes = len;
 540                         send = chophere = s + itembytes;
 541                         while (s < send) {
 542                             if (*s & ~31)
 543                                 gotsome = TRUE;
 544                             else if (*s == '\n')
 545                                 break;
 546                             s++;
 547                         }
 548                         item_is_utf8 = TRUE;
 549                         itemsize = s - item;
 550                         sv_pos_b2u(sv, &itemsize);
 551                         break;
 552                     }
 553                 }
 554                 item_is_utf8 = FALSE;
 555                 if (itemsize > fieldsize)
 556                     itemsize = fieldsize;
 557                 send = chophere = s + itemsize;
 558                 while (s < send) {
 559                     if (*s & ~31)
 560                         gotsome = TRUE;
 561                     else if (*s == '\n')
 562                         break;
 563                     s++;
 564                 }
 565                 itemsize = s - item;
 566                 break;
 567             }
 568
 569         case FF_CHECKCHOP:
 570             {
 571                 const char *s = item = SvPV_const(sv, len);
 572                 itemsize = len;
 573                 if (DO_UTF8(sv)) {
 574                     itemsize = sv_len_utf8(sv);
 575                     if (itemsize != (I32)len) {
 576                         I32 itembytes;
 577                         if (itemsize <= fieldsize) {
 578                             const char *send = chophere = s + itemsize;
 579                             while (s < send) {
 580                                 if (*s == '\r') {
 581                                     itemsize = s - item;
 582                                     chophere = s;
 583                                     break;
 584                                 }
 585                                 if (*s++ & ~31)
 586                                     gotsome = TRUE;
 587                             }
 588                         }
 589                         else {
 590                             const char *send;
 591                             itemsize = fieldsize;
 592                             itembytes = itemsize;
 593                             sv_pos_u2b(sv, &itembytes, 0);
 594                             send = chophere = s + itembytes;
 595                             while (s < send || (s == send && isSPACE(*s))) {
 596                                 if (isSPACE(*s)) {
 597                                     if (chopspace)
 598                                         chophere = s;
 599                                     if (*s == '\r')
 600                                         break;
 601                                 }
 602                                 else {
 603                                     if (*s & ~31)
 604                                         gotsome = TRUE;
 605                                     if (strchr(PL_chopset, *s))
 606                                         chophere = s + 1;
 607                                 }
 608                                 s++;
 609                             }
 610                             itemsize = chophere - item;
 611                             sv_pos_b2u(sv, &itemsize);
 612                         }
 613                         item_is_utf8 = TRUE;
 614                         break;
 615                     }
 616                 }
 617                 item_is_utf8 = FALSE;
 618                 if (itemsize <= fieldsize) {
 619                     const char *const send = chophere = s + itemsize;
 620                     while (s < send) {
 621                         if (*s == '\r') {
 622                             itemsize = s - item;
 623                             chophere = s;
 624                             break;
 625                         }
 626                         if (*s++ & ~31)
 627                             gotsome = TRUE;
 628                     }
 629                 }
 630                 else {
 631                     const char *send;
 632                     itemsize = fieldsize;
 633                     send = chophere = s + itemsize;
 634                     while (s < send || (s == send && isSPACE(*s))) {
 635                         if (isSPACE(*s)) {
 636                             if (chopspace)
 637                                 chophere = s;
 638                             if (*s == '\r')
 639                                 break;
 640                         }
 641                         else {
 642                             if (*s & ~31)
 643                                 gotsome = TRUE;
 644                             if (strchr(PL_chopset, *s))
 645                                 chophere = s + 1;
 646                         }
 647                         s++;
 648                     }
 649                     itemsize = chophere - item;
 650                 }
 651                 break;
 652             }
 653
 654         case FF_SPACE:
 655             arg = fieldsize - itemsize;
 656             if (arg) {
 657                 fieldsize -= arg;
 658                 while (arg-- > 0)
 659                     *t++ = ' ';
 660             }
 661             break;
 662
 663         case FF_HALFSPACE:
 664             arg = fieldsize - itemsize;
 665             if (arg) {
 666                 arg /= 2;
 667                 fieldsize -= arg;
 668                 while (arg-- > 0)
 669                     *t++ = ' ';
 670             }
 671             break;
 672
 673         case FF_ITEM:
 674             {
 675                 const char *s = item;
 676                 arg = itemsize;
 677                 if (item_is_utf8) {
 678                     if (!targ_is_utf8) {
 679                         SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 680                         *t = '\0';
 681                         sv_utf8_upgrade(PL_formtarget);
 682                         SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 683                         t = SvEND(PL_formtarget);
 684                         targ_is_utf8 = TRUE;
 685                     }
 686                     while (arg--) {
 687                         if (UTF8_IS_CONTINUED(*s)) {
 688                             STRLEN skip = UTF8SKIP(s);
 689                             switch (skip) {
 690                             default:
 691                                 Move(s,t,skip,char);
 692                                 s += skip;
 693                                 t += skip;
 694                                 break;
 695                             case 7: *t++ = *s++;
 696                             case 6: *t++ = *s++;
 697                             case 5: *t++ = *s++;
 698                             case 4: *t++ = *s++;
 699                             case 3: *t++ = *s++;
 700                             case 2: *t++ = *s++;
 701                             case 1: *t++ = *s++;
 702                             }
 703                         }
 704                         else {
 705                             if ( !((*t++ = *s++) & ~31) )
 706                                 t[-1] = ' ';
 707                         }
 708                     }
 709                     break;
 710                 }
 711                 if (targ_is_utf8 && !item_is_utf8) {
 712                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 713                     *t = '\0';
 714                     sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 715                     for (; t < SvEND(PL_formtarget); t++) {
 716 #ifdef EBCDIC
 717                         const int ch = *t;
 718                         if (iscntrl(ch))
 719 #else
 720                             if (!(*t & ~31))
 721 #endif
 722                                 *t = ' ';
 723                     }
 724                     break;
 725                 }
 726                 while (arg--) {
 727 #ifdef EBCDIC
 728                     const int ch = *t++ = *s++;
 729                     if (iscntrl(ch))
 730 #else
 731                         if ( !((*t++ = *s++) & ~31) )
 732 #endif
 733                             t[-1] = ' ';
 734                 }
 735                 break;
 736             }
 737
 738         case FF_CHOP:
 739             {
 740                 const char *s = chophere;
 741                 if (chopspace) {
 742                     while (isSPACE(*s))
 743                         s++;
 744                 }
 745                 sv_chop(sv,s);
 746                 SvSETMAGIC(sv);
 747                 break;
 748             }
 749
 750         case FF_LINESNGL:
 751             chopspace = 0;
 752             oneline = TRUE;
 753             goto ff_line;
 754         case FF_LINEGLOB:
 755             oneline = FALSE;
 756         ff_line:
 757             {
 758                 const char *s = item = SvPV_const(sv, len);
 759                 itemsize = len;
 760                 if ((item_is_utf8 = DO_UTF8(sv)))
 761                     itemsize = sv_len_utf8(sv);
 762                 if (itemsize) {
 763                     bool chopped = FALSE;
 764                     const char *const send = s + len;
 765                     gotsome = TRUE;
 766                     chophere = s + itemsize;
 767                     while (s < send) {
 768                         if (*s++ == '\n') {
 769                             if (oneline) {
 770                                 chopped = TRUE;
 771                                 chophere = s;
 772                                 break;
 773                             } else {
 774                                 if (s == send) {
 775                                     itemsize--;
 776                                     chopped = TRUE;
 777                                 } else
 778                                     lines++;
 779                             }
 780                         }
 781                     }
 782                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 783                     if (targ_is_utf8)
 784                         SvUTF8_on(PL_formtarget);
 785                     if (oneline) {
 786                         SvCUR_set(sv, chophere - item);
 787                         sv_catsv(PL_formtarget, sv);
 788                         SvCUR_set(sv, itemsize);
 789                     } else
 790                         sv_catsv(PL_formtarget, sv);
 791                     if (chopped)
 792                         SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
 793                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 794                     t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 795                     if (item_is_utf8)
 796                         targ_is_utf8 = TRUE;
 797                 }
 798                 break;
 799             }
 800
 801         case FF_0DECIMAL:
 802             arg = *fpc++;
 803 #if defined(USE_LONG_DOUBLE)
 804             fmt = (const char *)
 805                 ((arg & 256) ?
 806                  "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
 807 #else
 808             fmt = (const char *)
 809                 ((arg & 256) ?
 810                  "%#0*.*f"              : "%0*.*f");
 811 #endif
 812             goto ff_dec;
 813         case FF_DECIMAL:
 814             arg = *fpc++;
 815 #if defined(USE_LONG_DOUBLE)
 816             fmt = (const char *)
 817                 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
 818 #else
 819             fmt = (const char *)
 820                 ((arg & 256) ? "%#*.*f"              : "%*.*f");
 821 #endif
 822         ff_dec:
 823             /* If the field is marked with ^ and the value is undefined,
 824                blank it out. */
 825             if ((arg & 512) && !SvOK(sv)) {
 826                 arg = fieldsize;
 827                 while (arg--)
 828                     *t++ = ' ';
 829                 break;
 830             }
 831             gotsome = TRUE;
 832             value = SvNV(sv);
 833             /* overflow evidence */
 834             if (num_overflow(value, fieldsize, arg)) {
 835                 arg = fieldsize;
 836                 while (arg--)
 837                     *t++ = '#';
 838                 break;
 839             }
 840             /* Formats aren't yet marked for locales, so assume "yes". */
 841             {
 842                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 843                 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
 844                 RESTORE_NUMERIC_STANDARD();
 845             }
 846             t += fieldsize;
 847             break;
 848
 849         case FF_NEWLINE:
 850             f++;
 851             while (t-- > linemark && *t == ' ') ;
 852             t++;
 853             *t++ = '\n';
 854             break;
 855
 856         case FF_BLANK:
 857             arg = *fpc++;
 858             if (gotsome) {
 859                 if (arg) {              /* repeat until fields exhausted? */
 860                     *t = '\0';
 861                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 862                     lines += FmLINES(PL_formtarget);
 863                     if (lines == 200) {
 864                         arg = t - linemark;
 865                         if (strnEQ(linemark, linemark - arg, arg))
 866                             DIE(aTHX_ "Runaway format");
 867                     }
 868                     if (targ_is_utf8)
 869                         SvUTF8_on(PL_formtarget);
 870                     FmLINES(PL_formtarget) = lines;
 871                     SP = ORIGMARK;
 872                     RETURNOP(cLISTOP->op_first);
 873                 }
 874             }
 875             else {
 876                 t = linemark;
 877                 lines--;
 878             }
 879             break;
 880
 881         case FF_MORE:
 882             {
 883                 const char *s = chophere;
 884                 const char *send = item + len;
 885                 if (chopspace) {
 886                     while (isSPACE(*s) && (s < send))
 887                         s++;
 888                 }
 889                 if (s < send) {
 890                     char *s1;
 891                     arg = fieldsize - itemsize;
 892                     if (arg) {
 893                         fieldsize -= arg;
 894                         while (arg-- > 0)
 895                             *t++ = ' ';
 896                     }
 897                     s1 = t - 3;
 898                     if (strnEQ(s1,"   ",3)) {
 899                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
 900                             s1--;
 901                     }
 902                     *s1++ = '.';
 903                     *s1++ = '.';
 904                     *s1++ = '.';
 905                 }
 906                 break;
 907             }
 908         case FF_END:
 909             *t = '\0';
 910             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 911             if (targ_is_utf8)
 912                 SvUTF8_on(PL_formtarget);
 913             FmLINES(PL_formtarget) += lines;
 914             SP = ORIGMARK;
 915             RETPUSHYES;
 916         }
 917     }
 918 }
 919
 920 PP(pp_grepstart)
 921 {
 922     dVAR; dSP;
 923     SV *src;
 924
 925     if (PL_stack_base + *PL_markstack_ptr == SP) {
 926         (void)POPMARK;
 927         if (GIMME_V == G_SCALAR)
 928             XPUSHs(sv_2mortal(newSViv(0)));
 929         RETURNOP(PL_op->op_next->op_next);
 930     }
 931     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 932     pp_pushmark();                              /* push dst */
 933     pp_pushmark();                              /* push src */
 934     ENTER;                                      /* enter outer scope */
 935
 936     SAVETMPS;
 937     if (PL_op->op_private & OPpGREP_LEX)
 938         SAVESPTR(PAD_SVl(PL_op->op_targ));
 939     else
 940         SAVE_DEFSV;
 941     ENTER;                                      /* enter inner scope */
 942     SAVEVPTR(PL_curpm);
 943
 944     src = PL_stack_base[*PL_markstack_ptr];
 945     SvTEMP_off(src);
 946     if (PL_op->op_private & OPpGREP_LEX)
 947         PAD_SVl(PL_op->op_targ) = src;
 948     else
 949         DEFSV = src;
 950
 951     PUTBACK;
 952     if (PL_op->op_type == OP_MAPSTART)
 953         pp_pushmark();                  /* push top */
 954     return ((LOGOP*)PL_op->op_next)->op_other;
 955 }
 956
 957 PP(pp_mapwhile)
 958 {
 959     dVAR; dSP;
 960     const I32 gimme = GIMME_V;
 961     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
 962     I32 count;
 963     I32 shift;
 964     SV** src;
 965     SV** dst;
 966
 967     /* first, move source pointer to the next item in the source list */
 968     ++PL_markstack_ptr[-1];
 969
 970     /* if there are new items, push them into the destination list */
 971     if (items && gimme != G_VOID) {
 972         /* might need to make room back there first */
 973         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 974             /* XXX this implementation is very pessimal because the stack
 975              * is repeatedly extended for every set of items.  Is possible
 976              * to do this without any stack extension or copying at all
 977              * by maintaining a separate list over which the map iterates
 978              * (like foreach does). --gsar */
 979
 980             /* everything in the stack after the destination list moves
 981              * towards the end the stack by the amount of room needed */
 982             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 983
 984             /* items to shift up (accounting for the moved source pointer) */
 985             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
 986
 987             /* This optimization is by Ben Tilly and it does
 988              * things differently from what Sarathy (gsar)
 989              * is describing.  The downside of this optimization is
 990              * that leaves "holes" (uninitialized and hopefully unused areas)
 991              * to the Perl stack, but on the other hand this
 992              * shouldn't be a problem.  If Sarathy's idea gets
 993              * implemented, this optimization should become
 994              * irrelevant.  --jhi */
 995             if (shift < count)
 996                 shift = count; /* Avoid shifting too often --Ben Tilly */
 997
 998             EXTEND(SP,shift);
 999             src = SP;
1000             dst = (SP += shift);
1001             PL_markstack_ptr[-1] += shift;
1002             *PL_markstack_ptr += shift;
1003             while (count--)
1004                 *dst-- = *src--;
1005         }
1006         /* copy the new items down to the destination list */
1007         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1008         if (gimme == G_ARRAY) {
1009             while (items-- > 0)
1010                 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1011         }
1012         else {
1013             /* scalar context: we don't care about which values map returns
1014              * (we use undef here). And so we certainly don't want to do mortal
1015              * copies of meaningless values. */
1016             while (items-- > 0) {
1017                 (void)POPs;
1018                 *dst-- = &PL_sv_undef;
1019             }
1020         }
1021     }
1022     LEAVE;                                      /* exit inner scope */
1023
1024     /* All done yet? */
1025     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1026
1027         (void)POPMARK;                          /* pop top */
1028         LEAVE;                                  /* exit outer scope */
1029         (void)POPMARK;                          /* pop src */
1030         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1031         (void)POPMARK;                          /* pop dst */
1032         SP = PL_stack_base + POPMARK;           /* pop original mark */
1033         if (gimme == G_SCALAR) {
1034             if (PL_op->op_private & OPpGREP_LEX) {
1035                 SV* sv = sv_newmortal();
1036                 sv_setiv(sv, items);
1037                 PUSHs(sv);
1038             }
1039             else {
1040                 dTARGET;
1041                 XPUSHi(items);
1042             }
1043         }
1044         else if (gimme == G_ARRAY)
1045             SP += items;
1046         RETURN;
1047     }
1048     else {
1049         SV *src;
1050
1051         ENTER;                                  /* enter inner scope */
1052         SAVEVPTR(PL_curpm);
1053
1054         /* set $_ to the new source item */
1055         src = PL_stack_base[PL_markstack_ptr[-1]];
1056         SvTEMP_off(src);
1057         if (PL_op->op_private & OPpGREP_LEX)
1058             PAD_SVl(PL_op->op_targ) = src;
1059         else
1060             DEFSV = src;
1061
1062         RETURNOP(cLOGOP->op_other);
1063     }
1064 }
1065
1066 /* Range stuff. */
1067
1068 PP(pp_range)
1069 {
1070     dVAR;
1071     if (GIMME == G_ARRAY)
1072         return NORMAL;
1073     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1074         return cLOGOP->op_other;
1075     else
1076         return NORMAL;
1077 }
1078
1079 PP(pp_flip)
1080 {
1081     dVAR;
1082     dSP;
1083
1084     if (GIMME == G_ARRAY) {
1085         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1086     }
1087     else {
1088         dTOPss;
1089         SV * const targ = PAD_SV(PL_op->op_targ);
1090         int flip = 0;
1091
1092         if (PL_op->op_private & OPpFLIP_LINENUM) {
1093             if (GvIO(PL_last_in_gv)) {
1094                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1095             }
1096             else {
1097                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1098                 if (gv && GvSV(gv))
1099                     flip = SvIV(sv) == SvIV(GvSV(gv));
1100             }
1101         } else {
1102             flip = SvTRUE(sv);
1103         }
1104         if (flip) {
1105             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1106             if (PL_op->op_flags & OPf_SPECIAL) {
1107                 sv_setiv(targ, 1);
1108                 SETs(targ);
1109                 RETURN;
1110             }
1111             else {
1112                 sv_setiv(targ, 0);
1113                 SP--;
1114                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1115             }
1116         }
1117         sv_setpvn(TARG, "", 0);
1118         SETs(targ);
1119         RETURN;
1120     }
1121 }
1122
1123 /* This code tries to decide if "$left .. $right" should use the
1124    magical string increment, or if the range is numeric (we make
1125    an exception for .."0" [#18165]). AMS 20021031. */
1126
1127 #define RANGE_IS_NUMERIC(left,right) ( \
1128         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1129         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1130         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1131           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1132          && (!SvOK(right) || looks_like_number(right))))
1133
1134 PP(pp_flop)
1135 {
1136     dVAR; dSP;
1137
1138     if (GIMME == G_ARRAY) {
1139         dPOPPOPssrl;
1140
1141         SvGETMAGIC(left);
1142         SvGETMAGIC(right);
1143
1144         if (RANGE_IS_NUMERIC(left,right)) {
1145             register IV i, j;
1146             IV max;
1147             if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1148                 (SvOK(right) && SvNV(right) > IV_MAX))
1149                 DIE(aTHX_ "Range iterator outside integer range");
1150             i = SvIV(left);
1151             max = SvIV(right);
1152             if (max >= i) {
1153                 j = max - i + 1;
1154                 EXTEND_MORTAL(j);
1155                 EXTEND(SP, j);
1156             }
1157             else
1158                 j = 0;
1159             while (j--) {
1160                 SV * const sv = sv_2mortal(newSViv(i++));
1161                 PUSHs(sv);
1162             }
1163         }
1164         else {
1165             SV * const final = sv_mortalcopy(right);
1166             STRLEN len;
1167             const char * const tmps = SvPV_const(final, len);
1168
1169             SV *sv = sv_mortalcopy(left);
1170             SvPV_force_nolen(sv);
1171             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1172                 XPUSHs(sv);
1173                 if (strEQ(SvPVX_const(sv),tmps))
1174                     break;
1175                 sv = sv_2mortal(newSVsv(sv));
1176                 sv_inc(sv);
1177             }
1178         }
1179     }
1180     else {
1181         dTOPss;
1182         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1183         int flop = 0;
1184         sv_inc(targ);
1185
1186         if (PL_op->op_private & OPpFLIP_LINENUM) {
1187             if (GvIO(PL_last_in_gv)) {
1188                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1189             }
1190             else {
1191                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1192                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1193             }
1194         }
1195         else {
1196             flop = SvTRUE(sv);
1197         }
1198
1199         if (flop) {
1200             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1201             sv_catpvs(targ, "E0");
1202         }
1203         SETs(targ);
1204     }
1205
1206     RETURN;
1207 }
1208
1209 /* Control. */
1210
1211 static const char * const context_name[] = {
1212     "pseudo-block",
1213     "subroutine",
1214     "eval",
1215     "loop",
1216     "substitution",
1217     "block",
1218     "format",
1219     "given",
1220     "when"
1221 };
1222
1223 STATIC I32
1224 S_dopoptolabel(pTHX_ const char *label)
1225 {
1226     dVAR;
1227     register I32 i;
1228
1229     for (i = cxstack_ix; i >= 0; i--) {
1230         register const PERL_CONTEXT * const cx = &cxstack[i];
1231         switch (CxTYPE(cx)) {
1232         case CXt_SUBST:
1233         case CXt_SUB:
1234         case CXt_FORMAT:
1235         case CXt_EVAL:
1236         case CXt_NULL:
1237         case CXt_GIVEN:
1238         case CXt_WHEN:
1239             if (ckWARN(WARN_EXITING))
1240                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1241                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1242             if (CxTYPE(cx) == CXt_NULL)
1243                 return -1;
1244             break;
1245         case CXt_LOOP:
1246             if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1247                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1248                         (long)i, cx->blk_loop.label));
1249                 continue;
1250             }
1251             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1252             return i;
1253         }
1254     }
1255     return i;
1256 }
1257
1258
1259
1260 I32
1261 Perl_dowantarray(pTHX)
1262 {
1263     dVAR;
1264     const I32 gimme = block_gimme();
1265     return (gimme == G_VOID) ? G_SCALAR : gimme;
1266 }
1267
1268 I32
1269 Perl_block_gimme(pTHX)
1270 {
1271     dVAR;
1272     const I32 cxix = dopoptosub(cxstack_ix);
1273     if (cxix < 0)
1274         return G_VOID;
1275
1276     switch (cxstack[cxix].blk_gimme) {
1277     case G_VOID:
1278         return G_VOID;
1279     case G_SCALAR:
1280         return G_SCALAR;
1281     case G_ARRAY:
1282         return G_ARRAY;
1283     default:
1284         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1285         /* NOTREACHED */
1286         return 0;
1287     }
1288 }
1289
1290 I32
1291 Perl_is_lvalue_sub(pTHX)
1292 {
1293     dVAR;
1294     const I32 cxix = dopoptosub(cxstack_ix);
1295     assert(cxix >= 0);  /* We should only be called from inside subs */
1296
1297     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1298         return cxstack[cxix].blk_sub.lval;
1299     else
1300         return 0;
1301 }
1302
1303 STATIC I32
1304 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1305 {
1306     dVAR;
1307     I32 i;
1308     for (i = startingblock; i >= 0; i--) {
1309         register const PERL_CONTEXT * const cx = &cxstk[i];
1310         switch (CxTYPE(cx)) {
1311         default:
1312             continue;
1313         case CXt_EVAL:
1314         case CXt_SUB:
1315         case CXt_FORMAT:
1316             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1317             return i;
1318         }
1319     }
1320     return i;
1321 }
1322
1323 STATIC I32
1324 S_dopoptoeval(pTHX_ I32 startingblock)
1325 {
1326     dVAR;
1327     I32 i;
1328     for (i = startingblock; i >= 0; i--) {
1329         register const PERL_CONTEXT *cx = &cxstack[i];
1330         switch (CxTYPE(cx)) {
1331         default:
1332             continue;
1333         case CXt_EVAL:
1334             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1335             return i;
1336         }
1337     }
1338     return i;
1339 }
1340
1341 STATIC I32
1342 S_dopoptoloop(pTHX_ I32 startingblock)
1343 {
1344     dVAR;
1345     I32 i;
1346     for (i = startingblock; i >= 0; i--) {
1347         register const PERL_CONTEXT * const cx = &cxstack[i];
1348         switch (CxTYPE(cx)) {
1349         case CXt_SUBST:
1350         case CXt_SUB:
1351         case CXt_FORMAT:
1352         case CXt_EVAL:
1353         case CXt_NULL:
1354             if (ckWARN(WARN_EXITING))
1355                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1356                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1357             if ((CxTYPE(cx)) == CXt_NULL)
1358                 return -1;
1359             break;
1360         case CXt_LOOP:
1361             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1362             return i;
1363         }
1364     }
1365     return i;
1366 }
1367
1368 STATIC I32
1369 S_dopoptogiven(pTHX_ I32 startingblock)
1370 {
1371     dVAR;
1372     I32 i;
1373     for (i = startingblock; i >= 0; i--) {
1374         register const PERL_CONTEXT *cx = &cxstack[i];
1375         switch (CxTYPE(cx)) {
1376         default:
1377             continue;
1378         case CXt_GIVEN:
1379             DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1380             return i;
1381         case CXt_LOOP:
1382             if (CxFOREACHDEF(cx)) {
1383                 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1384                 return i;
1385             }
1386         }
1387     }
1388     return i;
1389 }
1390
1391 STATIC I32
1392 S_dopoptowhen(pTHX_ I32 startingblock)
1393 {
1394     dVAR;
1395     I32 i;
1396     for (i = startingblock; i >= 0; i--) {
1397         register const PERL_CONTEXT *cx = &cxstack[i];
1398         switch (CxTYPE(cx)) {
1399         default:
1400             continue;
1401         case CXt_WHEN:
1402             DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1403             return i;
1404         }
1405     }
1406     return i;
1407 }
1408
1409 void
1410 Perl_dounwind(pTHX_ I32 cxix)
1411 {
1412     dVAR;
1413     I32 optype;
1414
1415     while (cxstack_ix > cxix) {
1416         SV *sv;
1417         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1418         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1419                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1420         /* Note: we don't need to restore the base context info till the end. */
1421         switch (CxTYPE(cx)) {
1422         case CXt_SUBST:
1423             POPSUBST(cx);
1424             continue;  /* not break */
1425         case CXt_SUB:
1426             POPSUB(cx,sv);
1427             LEAVESUB(sv);
1428             break;
1429         case CXt_EVAL:
1430             POPEVAL(cx);
1431             break;
1432         case CXt_LOOP:
1433             POPLOOP(cx);
1434             break;
1435         case CXt_NULL:
1436             break;
1437         case CXt_FORMAT:
1438             POPFORMAT(cx);
1439             break;
1440         }
1441         cxstack_ix--;
1442     }
1443     PERL_UNUSED_VAR(optype);
1444 }
1445
1446 void
1447 Perl_qerror(pTHX_ SV *err)
1448 {
1449     dVAR;
1450     if (PL_in_eval)
1451         sv_catsv(ERRSV, err);
1452     else if (PL_errors)
1453         sv_catsv(PL_errors, err);
1454     else
1455         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1456     if (PL_parser)
1457         ++PL_parser->error_count;
1458 }
1459
1460 OP *
1461 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1462 {
1463     dVAR;
1464
1465     if (PL_in_eval) {
1466         I32 cxix;
1467         I32 gimme;
1468
1469         if (message) {
1470             if (PL_in_eval & EVAL_KEEPERR) {
1471                 static const char prefix[] = "\t(in cleanup) ";
1472                 SV * const err = ERRSV;
1473                 const char *e = NULL;
1474                 if (!SvPOK(err))
1475                     sv_setpvn(err,"",0);
1476                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1477                     STRLEN len;
1478                     e = SvPV_const(err, len);
1479                     e += len - msglen;
1480                     if (*e != *message || strNE(e,message))
1481                         e = NULL;
1482                 }
1483                 if (!e) {
1484                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1485                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1486                     sv_catpvn(err, message, msglen);
1487                     if (ckWARN(WARN_MISC)) {
1488                         const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1489                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1490                     }
1491                 }
1492             }
1493             else {
1494                 sv_setpvn(ERRSV, message, msglen);
1495             }
1496         }
1497
1498         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1499                && PL_curstackinfo->si_prev)
1500         {
1501             dounwind(-1);
1502             POPSTACK;
1503         }
1504
1505         if (cxix >= 0) {
1506             I32 optype;
1507             register PERL_CONTEXT *cx;
1508             SV **newsp;
1509
1510             if (cxix < cxstack_ix)
1511                 dounwind(cxix);
1512
1513             POPBLOCK(cx,PL_curpm);
1514             if (CxTYPE(cx) != CXt_EVAL) {
1515                 if (!message)
1516                     message = SvPVx_const(ERRSV, msglen);
1517                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1518                 PerlIO_write(Perl_error_log, message, msglen);
1519                 my_exit(1);
1520             }
1521             POPEVAL(cx);
1522
1523             if (gimme == G_SCALAR)
1524                 *++newsp = &PL_sv_undef;
1525             PL_stack_sp = newsp;
1526
1527             LEAVE;
1528
1529             /* LEAVE could clobber PL_curcop (see save_re_context())
1530              * XXX it might be better to find a way to avoid messing with
1531              * PL_curcop in save_re_context() instead, but this is a more
1532              * minimal fix --GSAR */
1533             PL_curcop = cx->blk_oldcop;
1534
1535             if (optype == OP_REQUIRE) {
1536                 const char* const msg = SvPVx_nolen_const(ERRSV);
1537                 SV * const nsv = cx->blk_eval.old_namesv;
1538                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1539                                &PL_sv_undef, 0);
1540                 DIE(aTHX_ "%sCompilation failed in require",
1541                     *msg ? msg : "Unknown error\n");
1542             }
1543             assert(CxTYPE(cx) == CXt_EVAL);
1544             return cx->blk_eval.retop;
1545         }
1546     }
1547     if (!message)
1548         message = SvPVx_const(ERRSV, msglen);
1549
1550     write_to_stderr(message, msglen);
1551     my_failure_exit();
1552     /* NOTREACHED */
1553     return 0;
1554 }
1555
1556 PP(pp_xor)
1557 {
1558     dVAR; dSP; dPOPTOPssrl;
1559     if (SvTRUE(left) != SvTRUE(right))
1560         RETSETYES;
1561     else
1562         RETSETNO;
1563 }
1564
1565 PP(pp_caller)
1566 {
1567     dVAR;
1568     dSP;
1569     register I32 cxix = dopoptosub(cxstack_ix);
1570     register const PERL_CONTEXT *cx;
1571     register const PERL_CONTEXT *ccstack = cxstack;
1572     const PERL_SI *top_si = PL_curstackinfo;
1573     I32 gimme;
1574     const char *stashname;
1575     I32 count = 0;
1576
1577     if (MAXARG)
1578         count = POPi;
1579
1580     for (;;) {
1581         /* we may be in a higher stacklevel, so dig down deeper */
1582         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1583             top_si = top_si->si_prev;
1584             ccstack = top_si->si_cxstack;
1585             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1586         }
1587         if (cxix < 0) {
1588             if (GIMME != G_ARRAY) {
1589                 EXTEND(SP, 1);
1590                 RETPUSHUNDEF;
1591             }
1592             RETURN;
1593         }
1594         /* caller() should not report the automatic calls to &DB::sub */
1595         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1596                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1597             count++;
1598         if (!count--)
1599             break;
1600         cxix = dopoptosub_at(ccstack, cxix - 1);
1601     }
1602
1603     cx = &ccstack[cxix];
1604     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1605         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1606         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1607            field below is defined for any cx. */
1608         /* caller() should not report the automatic calls to &DB::sub */
1609         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1610             cx = &ccstack[dbcxix];
1611     }
1612
1613     stashname = CopSTASHPV(cx->blk_oldcop);
1614     if (GIMME != G_ARRAY) {
1615         EXTEND(SP, 1);
1616         if (!stashname)
1617             PUSHs(&PL_sv_undef);
1618         else {
1619             dTARGET;
1620             sv_setpv(TARG, stashname);
1621             PUSHs(TARG);
1622         }
1623         RETURN;
1624     }
1625
1626     EXTEND(SP, 11);
1627
1628     if (!stashname)
1629         PUSHs(&PL_sv_undef);
1630     else
1631         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1632     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1633     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1634     if (!MAXARG)
1635         RETURN;
1636     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1637         GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1638         /* So is ccstack[dbcxix]. */
1639         if (isGV(cvgv)) {
1640             SV * const sv = newSV(0);
1641             gv_efullname3(sv, cvgv, NULL);
1642             PUSHs(sv_2mortal(sv));
1643             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1644         }
1645         else {
1646             PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1647             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1648         }
1649     }
1650     else {
1651         PUSHs(sv_2mortal(newSVpvs("(eval)")));
1652         PUSHs(sv_2mortal(newSViv(0)));
1653     }
1654     gimme = (I32)cx->blk_gimme;
1655     if (gimme == G_VOID)
1656         PUSHs(&PL_sv_undef);
1657     else
1658         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1659     if (CxTYPE(cx) == CXt_EVAL) {
1660         /* eval STRING */
1661         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1662             PUSHs(cx->blk_eval.cur_text);
1663             PUSHs(&PL_sv_no);
1664         }
1665         /* require */
1666         else if (cx->blk_eval.old_namesv) {
1667             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1668             PUSHs(&PL_sv_yes);
1669         }
1670         /* eval BLOCK (try blocks have old_namesv == 0) */
1671         else {
1672             PUSHs(&PL_sv_undef);
1673             PUSHs(&PL_sv_undef);
1674         }
1675     }
1676     else {
1677         PUSHs(&PL_sv_undef);
1678         PUSHs(&PL_sv_undef);
1679     }
1680     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1681         && CopSTASH_eq(PL_curcop, PL_debstash))
1682     {
1683         AV * const ary = cx->blk_sub.argarray;
1684         const int off = AvARRAY(ary) - AvALLOC(ary);
1685
1686         if (!PL_dbargs) {
1687             GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1688             PL_dbargs = GvAV(gv_AVadd(tmpgv));
1689             GvMULTI_on(tmpgv);
1690             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1691         }
1692
1693         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1694             av_extend(PL_dbargs, AvFILLp(ary) + off);
1695         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1696         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1697     }
1698     /* XXX only hints propagated via op_private are currently
1699      * visible (others are not easily accessible, since they
1700      * use the global PL_hints) */
1701     PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1702     {
1703         SV * mask ;
1704         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1705
1706         if  (old_warnings == pWARN_NONE ||
1707                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1708             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1709         else if (old_warnings == pWARN_ALL ||
1710                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1711             /* Get the bit mask for $warnings::Bits{all}, because
1712              * it could have been extended by warnings::register */
1713             SV **bits_all;
1714             HV * const bits = get_hv("warnings::Bits", FALSE);
1715             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1716                 mask = newSVsv(*bits_all);
1717             }
1718             else {
1719                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1720             }
1721         }
1722         else
1723             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1724         PUSHs(sv_2mortal(mask));
1725     }
1726
1727     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1728           sv_2mortal(newRV_noinc(
1729             (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1730                                               cx->blk_oldcop->cop_hints_hash)))
1731           : &PL_sv_undef);
1732     RETURN;
1733 }
1734
1735 PP(pp_reset)
1736 {
1737     dVAR;
1738     dSP;
1739     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1740     sv_reset(tmps, CopSTASH(PL_curcop));
1741     PUSHs(&PL_sv_yes);
1742     RETURN;
1743 }
1744
1745 /* like pp_nextstate, but used instead when the debugger is active */
1746
1747 PP(pp_dbstate)
1748 {
1749     dVAR;
1750     PL_curcop = (COP*)PL_op;
1751     TAINT_NOT;          /* Each statement is presumed innocent */
1752     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1753     FREETMPS;
1754
1755     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1756             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1757     {
1758         dSP;
1759         register PERL_CONTEXT *cx;
1760         const I32 gimme = G_ARRAY;
1761         U8 hasargs;
1762         GV * const gv = PL_DBgv;
1763         register CV * const cv = GvCV(gv);
1764
1765         if (!cv)
1766             DIE(aTHX_ "No DB::DB routine defined");
1767
1768         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1769             /* don't do recursive DB::DB call */
1770             return NORMAL;
1771
1772         ENTER;
1773         SAVETMPS;
1774
1775         SAVEI32(PL_debug);
1776         SAVESTACK_POS();
1777         PL_debug = 0;
1778         hasargs = 0;
1779         SPAGAIN;
1780
1781         if (CvISXSUB(cv)) {
1782             CvDEPTH(cv)++;
1783             PUSHMARK(SP);
1784             (void)(*CvXSUB(cv))(aTHX_ cv);
1785             CvDEPTH(cv)--;
1786             FREETMPS;
1787             LEAVE;
1788             return NORMAL;
1789         }
1790         else {
1791             PUSHBLOCK(cx, CXt_SUB, SP);
1792             PUSHSUB_DB(cx);
1793             cx->blk_sub.retop = PL_op->op_next;
1794             CvDEPTH(cv)++;
1795             SAVECOMPPAD();
1796             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1797             RETURNOP(CvSTART(cv));
1798         }
1799     }
1800     else
1801         return NORMAL;
1802 }
1803
1804 PP(pp_enteriter)
1805 {
1806     dVAR; dSP; dMARK;
1807     register PERL_CONTEXT *cx;
1808     const I32 gimme = GIMME_V;
1809     SV **svp;
1810     U16 cxtype = CXt_LOOP | CXp_FOREACH;
1811 #ifdef USE_ITHREADS
1812     void *iterdata;
1813 #endif
1814
1815     ENTER;
1816     SAVETMPS;
1817
1818     if (PL_op->op_targ) {
1819         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1820             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1821             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1822                     SVs_PADSTALE, SVs_PADSTALE);
1823         }
1824 #ifndef USE_ITHREADS
1825         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1826         SAVESPTR(*svp);
1827 #else
1828         SAVEPADSV(PL_op->op_targ);
1829         iterdata = INT2PTR(void*, PL_op->op_targ);
1830         cxtype |= CXp_PADVAR;
1831 #endif
1832     }
1833     else {
1834         GV * const gv = (GV*)POPs;
1835         svp = &GvSV(gv);                        /* symbol table variable */
1836         SAVEGENERICSV(*svp);
1837         *svp = newSV(0);
1838 #ifdef USE_ITHREADS
1839         iterdata = (void*)gv;
1840 #endif
1841     }
1842
1843     if (PL_op->op_private & OPpITER_DEF)
1844         cxtype |= CXp_FOR_DEF;
1845
1846     ENTER;
1847
1848     PUSHBLOCK(cx, cxtype, SP);
1849 #ifdef USE_ITHREADS
1850     PUSHLOOP(cx, iterdata, MARK);
1851 #else
1852     PUSHLOOP(cx, svp, MARK);
1853 #endif
1854     if (PL_op->op_flags & OPf_STACKED) {
1855         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1856         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1857             dPOPss;
1858             SV * const right = (SV*)cx->blk_loop.iterary;
1859             SvGETMAGIC(sv);
1860             SvGETMAGIC(right);
1861             if (RANGE_IS_NUMERIC(sv,right)) {
1862                 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1863                     (SvOK(right) && SvNV(right) >= IV_MAX))
1864                     DIE(aTHX_ "Range iterator outside integer range");
1865                 cx->blk_loop.iterix = SvIV(sv);
1866                 cx->blk_loop.itermax = SvIV(right);
1867 #ifdef DEBUGGING
1868                 /* for correct -Dstv display */
1869                 cx->blk_oldsp = sp - PL_stack_base;
1870 #endif
1871             }
1872             else {
1873                 cx->blk_loop.iterlval = newSVsv(sv);
1874                 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1875                 (void) SvPV_nolen_const(right);
1876             }
1877         }
1878         else if (PL_op->op_private & OPpITER_REVERSED) {
1879             cx->blk_loop.itermax = 0;
1880             cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1881
1882         }
1883     }
1884     else {
1885         cx->blk_loop.iterary = PL_curstack;
1886         AvFILLp(PL_curstack) = SP - PL_stack_base;
1887         if (PL_op->op_private & OPpITER_REVERSED) {
1888             cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1889             cx->blk_loop.iterix = cx->blk_oldsp + 1;
1890         }
1891         else {
1892             cx->blk_loop.iterix = MARK - PL_stack_base;
1893         }
1894     }
1895
1896     RETURN;
1897 }
1898
1899 PP(pp_enterloop)
1900 {
1901     dVAR; dSP;
1902     register PERL_CONTEXT *cx;
1903     const I32 gimme = GIMME_V;
1904
1905     ENTER;
1906     SAVETMPS;
1907     ENTER;
1908
1909     PUSHBLOCK(cx, CXt_LOOP, SP);
1910     PUSHLOOP(cx, 0, SP);
1911
1912     RETURN;
1913 }
1914
1915 PP(pp_leaveloop)
1916 {
1917     dVAR; dSP;
1918     register PERL_CONTEXT *cx;
1919     I32 gimme;
1920     SV **newsp;
1921     PMOP *newpm;
1922     SV **mark;
1923
1924     POPBLOCK(cx,newpm);
1925     assert(CxTYPE(cx) == CXt_LOOP);
1926     mark = newsp;
1927     newsp = PL_stack_base + cx->blk_loop.resetsp;
1928
1929     TAINT_NOT;
1930     if (gimme == G_VOID)
1931         NOOP;
1932     else if (gimme == G_SCALAR) {
1933         if (mark < SP)
1934             *++newsp = sv_mortalcopy(*SP);
1935         else
1936             *++newsp = &PL_sv_undef;
1937     }
1938     else {
1939         while (mark < SP) {
1940             *++newsp = sv_mortalcopy(*++mark);
1941             TAINT_NOT;          /* Each item is independent */
1942         }
1943     }
1944     SP = newsp;
1945     PUTBACK;
1946
1947     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1948     PL_curpm = newpm;   /* ... and pop $1 et al */
1949
1950     LEAVE;
1951     LEAVE;
1952
1953     return NORMAL;
1954 }
1955
1956 PP(pp_return)
1957 {
1958     dVAR; dSP; dMARK;
1959     register PERL_CONTEXT *cx;
1960     bool popsub2 = FALSE;
1961     bool clear_errsv = FALSE;
1962     I32 gimme;
1963     SV **newsp;
1964     PMOP *newpm;
1965     I32 optype = 0;
1966     SV *sv;
1967     OP *retop;
1968
1969     const I32 cxix = dopoptosub(cxstack_ix);
1970
1971     if (cxix < 0) {
1972         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1973                                      * sort block, which is a CXt_NULL
1974                                      * not a CXt_SUB */
1975             dounwind(0);
1976             PL_stack_base[1] = *PL_stack_sp;
1977             PL_stack_sp = PL_stack_base + 1;
1978             return 0;
1979         }
1980         else
1981             DIE(aTHX_ "Can't return outside a subroutine");
1982     }
1983     if (cxix < cxstack_ix)
1984         dounwind(cxix);
1985
1986     if (CxMULTICALL(&cxstack[cxix])) {
1987         gimme = cxstack[cxix].blk_gimme;
1988         if (gimme == G_VOID)
1989             PL_stack_sp = PL_stack_base;
1990         else if (gimme == G_SCALAR) {
1991             PL_stack_base[1] = *PL_stack_sp;
1992             PL_stack_sp = PL_stack_base + 1;
1993         }
1994         return 0;
1995     }
1996
1997     POPBLOCK(cx,newpm);
1998     switch (CxTYPE(cx)) {
1999     case CXt_SUB:
2000         popsub2 = TRUE;
2001         retop = cx->blk_sub.retop;
2002         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2003         break;
2004     case CXt_EVAL:
2005         if (!(PL_in_eval & EVAL_KEEPERR))
2006             clear_errsv = TRUE;
2007         POPEVAL(cx);
2008         retop = cx->blk_eval.retop;
2009         if (CxTRYBLOCK(cx))
2010             break;
2011         lex_end();
2012         if (optype == OP_REQUIRE &&
2013             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2014         {
2015             /* Unassume the success we assumed earlier. */
2016             SV * const nsv = cx->blk_eval.old_namesv;
2017             (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2018             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2019         }
2020         break;
2021     case CXt_FORMAT:
2022         POPFORMAT(cx);
2023         retop = cx->blk_sub.retop;
2024         break;
2025     default:
2026         DIE(aTHX_ "panic: return");
2027     }
2028
2029     TAINT_NOT;
2030     if (gimme == G_SCALAR) {
2031         if (MARK < SP) {
2032             if (popsub2) {
2033                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2034                     if (SvTEMP(TOPs)) {
2035                         *++newsp = SvREFCNT_inc(*SP);
2036                         FREETMPS;
2037                         sv_2mortal(*newsp);
2038                     }
2039                     else {
2040                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2041                         FREETMPS;
2042                         *++newsp = sv_mortalcopy(sv);
2043                         SvREFCNT_dec(sv);
2044                     }
2045                 }
2046                 else
2047                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2048             }
2049             else
2050                 *++newsp = sv_mortalcopy(*SP);
2051         }
2052         else
2053             *++newsp = &PL_sv_undef;
2054     }
2055     else if (gimme == G_ARRAY) {
2056         while (++MARK <= SP) {
2057             *++newsp = (popsub2 && SvTEMP(*MARK))
2058                         ? *MARK : sv_mortalcopy(*MARK);
2059             TAINT_NOT;          /* Each item is independent */
2060         }
2061     }
2062     PL_stack_sp = newsp;
2063
2064     LEAVE;
2065     /* Stack values are safe: */
2066     if (popsub2) {
2067         cxstack_ix--;
2068         POPSUB(cx,sv);  /* release CV and @_ ... */
2069     }
2070     else
2071         sv = NULL;
2072     PL_curpm = newpm;   /* ... and pop $1 et al */
2073
2074     LEAVESUB(sv);
2075     if (clear_errsv)
2076         sv_setpvn(ERRSV,"",0);
2077     return retop;
2078 }
2079
2080 PP(pp_last)
2081 {
2082     dVAR; dSP;
2083     I32 cxix;
2084     register PERL_CONTEXT *cx;
2085     I32 pop2 = 0;
2086     I32 gimme;
2087     I32 optype;
2088     OP *nextop;
2089     SV **newsp;
2090     PMOP *newpm;
2091     SV **mark;
2092     SV *sv = NULL;
2093
2094
2095     if (PL_op->op_flags & OPf_SPECIAL) {
2096         cxix = dopoptoloop(cxstack_ix);
2097         if (cxix < 0)
2098             DIE(aTHX_ "Can't \"last\" outside a loop block");
2099     }
2100     else {
2101         cxix = dopoptolabel(cPVOP->op_pv);
2102         if (cxix < 0)
2103             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2104     }
2105     if (cxix < cxstack_ix)
2106         dounwind(cxix);
2107
2108     POPBLOCK(cx,newpm);
2109     cxstack_ix++; /* temporarily protect top context */
2110     mark = newsp;
2111     switch (CxTYPE(cx)) {
2112     case CXt_LOOP:
2113         pop2 = CXt_LOOP;
2114         newsp = PL_stack_base + cx->blk_loop.resetsp;
2115         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2116         break;
2117     case CXt_SUB:
2118         pop2 = CXt_SUB;
2119         nextop = cx->blk_sub.retop;
2120         break;
2121     case CXt_EVAL:
2122         POPEVAL(cx);
2123         nextop = cx->blk_eval.retop;
2124         break;
2125     case CXt_FORMAT:
2126         POPFORMAT(cx);
2127         nextop = cx->blk_sub.retop;
2128         break;
2129     default:
2130         DIE(aTHX_ "panic: last");
2131     }
2132
2133     TAINT_NOT;
2134     if (gimme == G_SCALAR) {
2135         if (MARK < SP)
2136             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2137                         ? *SP : sv_mortalcopy(*SP);
2138         else
2139             *++newsp = &PL_sv_undef;
2140     }
2141     else if (gimme == G_ARRAY) {
2142         while (++MARK <= SP) {
2143             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2144                         ? *MARK : sv_mortalcopy(*MARK);
2145             TAINT_NOT;          /* Each item is independent */
2146         }
2147     }
2148     SP = newsp;
2149     PUTBACK;
2150
2151     LEAVE;
2152     cxstack_ix--;
2153     /* Stack values are safe: */
2154     switch (pop2) {
2155     case CXt_LOOP:
2156         POPLOOP(cx);    /* release loop vars ... */
2157         LEAVE;
2158         break;
2159     case CXt_SUB:
2160         POPSUB(cx,sv);  /* release CV and @_ ... */
2161         break;
2162     }
2163     PL_curpm = newpm;   /* ... and pop $1 et al */
2164
2165     LEAVESUB(sv);
2166     PERL_UNUSED_VAR(optype);
2167     PERL_UNUSED_VAR(gimme);
2168     return nextop;
2169 }
2170
2171 PP(pp_next)
2172 {
2173     dVAR;
2174     I32 cxix;
2175     register PERL_CONTEXT *cx;
2176     I32 inner;
2177
2178     if (PL_op->op_flags & OPf_SPECIAL) {
2179         cxix = dopoptoloop(cxstack_ix);
2180         if (cxix < 0)
2181             DIE(aTHX_ "Can't \"next\" outside a loop block");
2182     }
2183     else {
2184         cxix = dopoptolabel(cPVOP->op_pv);
2185         if (cxix < 0)
2186             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2187     }
2188     if (cxix < cxstack_ix)
2189         dounwind(cxix);
2190
2191     /* clear off anything above the scope we're re-entering, but
2192      * save the rest until after a possible continue block */
2193     inner = PL_scopestack_ix;
2194     TOPBLOCK(cx);
2195     if (PL_scopestack_ix < inner)
2196         leave_scope(PL_scopestack[PL_scopestack_ix]);
2197     PL_curcop = cx->blk_oldcop;
2198     return CX_LOOP_NEXTOP_GET(cx);
2199 }
2200
2201 PP(pp_redo)
2202 {
2203     dVAR;
2204     I32 cxix;
2205     register PERL_CONTEXT *cx;
2206     I32 oldsave;
2207     OP* redo_op;
2208
2209     if (PL_op->op_flags & OPf_SPECIAL) {
2210         cxix = dopoptoloop(cxstack_ix);
2211         if (cxix < 0)
2212             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2213     }
2214     else {
2215         cxix = dopoptolabel(cPVOP->op_pv);
2216         if (cxix < 0)
2217             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2218     }
2219     if (cxix < cxstack_ix)
2220         dounwind(cxix);
2221
2222     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2223     if (redo_op->op_type == OP_ENTER) {
2224         /* pop one less context to avoid $x being freed in while (my $x..) */
2225         cxstack_ix++;
2226         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2227         redo_op = redo_op->op_next;
2228     }
2229
2230     TOPBLOCK(cx);
2231     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2232     LEAVE_SCOPE(oldsave);
2233     FREETMPS;
2234     PL_curcop = cx->blk_oldcop;
2235     return redo_op;
2236 }
2237
2238 STATIC OP *
2239 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2240 {
2241     dVAR;
2242     OP **ops = opstack;
2243     static const char too_deep[] = "Target of goto is too deeply nested";
2244
2245     if (ops >= oplimit)
2246         Perl_croak(aTHX_ too_deep);
2247     if (o->op_type == OP_LEAVE ||
2248         o->op_type == OP_SCOPE ||
2249         o->op_type == OP_LEAVELOOP ||
2250         o->op_type == OP_LEAVESUB ||
2251         o->op_type == OP_LEAVETRY)
2252     {
2253         *ops++ = cUNOPo->op_first;
2254         if (ops >= oplimit)
2255             Perl_croak(aTHX_ too_deep);
2256     }
2257     *ops = 0;
2258     if (o->op_flags & OPf_KIDS) {
2259         OP *kid;
2260         /* First try all the kids at this level, since that's likeliest. */
2261         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2262             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2263                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2264                 return kid;
2265         }
2266         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2267             if (kid == PL_lastgotoprobe)
2268                 continue;
2269             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2270                 if (ops == opstack)
2271                     *ops++ = kid;
2272                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2273                          ops[-1]->op_type == OP_DBSTATE)
2274                     ops[-1] = kid;
2275                 else
2276                     *ops++ = kid;
2277             }
2278             if ((o = dofindlabel(kid, label, ops, oplimit)))
2279                 return o;
2280         }
2281     }
2282     *ops = 0;
2283     return 0;
2284 }
2285
2286 PP(pp_goto)
2287 {
2288     dVAR; dSP;
2289     OP *retop = NULL;
2290     I32 ix;
2291     register PERL_CONTEXT *cx;
2292 #define GOTO_DEPTH 64
2293     OP *enterops[GOTO_DEPTH];
2294     const char *label = NULL;
2295     const bool do_dump = (PL_op->op_type == OP_DUMP);
2296     static const char must_have_label[] = "goto must have label";
2297
2298     if (PL_op->op_flags & OPf_STACKED) {
2299         SV * const sv = POPs;
2300
2301         /* This egregious kludge implements goto &subroutine */
2302         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2303             I32 cxix;
2304             register PERL_CONTEXT *cx;
2305             CV* cv = (CV*)SvRV(sv);
2306             SV** mark;
2307             I32 items = 0;
2308             I32 oldsave;
2309             bool reified = 0;
2310
2311         retry:
2312             if (!CvROOT(cv) && !CvXSUB(cv)) {
2313                 const GV * const gv = CvGV(cv);
2314                 if (gv) {
2315                     GV *autogv;
2316                     SV *tmpstr;
2317                     /* autoloaded stub? */
2318                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2319                         goto retry;
2320                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2321                                           GvNAMELEN(gv), FALSE);
2322                     if (autogv && (cv = GvCV(autogv)))
2323                         goto retry;
2324                     tmpstr = sv_newmortal();
2325                     gv_efullname3(tmpstr, gv, NULL);
2326                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2327                 }
2328                 DIE(aTHX_ "Goto undefined subroutine");
2329             }
2330
2331             /* First do some returnish stuff. */
2332             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2333             FREETMPS;
2334             cxix = dopoptosub(cxstack_ix);
2335             if (cxix < 0)
2336                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2337             if (cxix < cxstack_ix)
2338                 dounwind(cxix);
2339             TOPBLOCK(cx);
2340             SPAGAIN;
2341             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2342             if (CxTYPE(cx) == CXt_EVAL) {
2343                 if (CxREALEVAL(cx))
2344                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2345                 else
2346                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2347             }
2348             else if (CxMULTICALL(cx))
2349                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2350             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2351                 /* put @_ back onto stack */
2352                 AV* av = cx->blk_sub.argarray;
2353
2354                 items = AvFILLp(av) + 1;
2355                 EXTEND(SP, items+1); /* @_ could have been extended. */
2356                 Copy(AvARRAY(av), SP + 1, items, SV*);
2357                 SvREFCNT_dec(GvAV(PL_defgv));
2358                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2359                 CLEAR_ARGARRAY(av);
2360                 /* abandon @_ if it got reified */
2361                 if (AvREAL(av)) {
2362                     reified = 1;
2363                     SvREFCNT_dec(av);
2364                     av = newAV();
2365                     av_extend(av, items-1);
2366                     AvREIFY_only(av);
2367                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2368                 }
2369             }
2370             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2371                 AV* const av = GvAV(PL_defgv);
2372                 items = AvFILLp(av) + 1;
2373                 EXTEND(SP, items+1); /* @_ could have been extended. */
2374                 Copy(AvARRAY(av), SP + 1, items, SV*);
2375             }
2376             mark = SP;
2377             SP += items;
2378             if (CxTYPE(cx) == CXt_SUB &&
2379                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2380                 SvREFCNT_dec(cx->blk_sub.cv);
2381             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2382             LEAVE_SCOPE(oldsave);
2383
2384             /* Now do some callish stuff. */
2385             SAVETMPS;
2386             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2387             if (CvISXSUB(cv)) {
2388                 OP* const retop = cx->blk_sub.retop;
2389                 SV **newsp;
2390                 I32 gimme;
2391                 if (reified) {
2392                     I32 index;
2393                     for (index=0; index<items; index++)
2394                         sv_2mortal(SP[-index]);
2395                 }
2396
2397                 /* XS subs don't have a CxSUB, so pop it */
2398                 POPBLOCK(cx, PL_curpm);
2399                 /* Push a mark for the start of arglist */
2400                 PUSHMARK(mark);
2401                 PUTBACK;
2402                 (void)(*CvXSUB(cv))(aTHX_ cv);
2403                 LEAVE;
2404                 return retop;
2405             }
2406             else {
2407                 AV* const padlist = CvPADLIST(cv);
2408                 if (CxTYPE(cx) == CXt_EVAL) {
2409                     PL_in_eval = cx->blk_eval.old_in_eval;
2410                     PL_eval_root = cx->blk_eval.old_eval_root;
2411                     cx->cx_type = CXt_SUB;
2412                     cx->blk_sub.hasargs = 0;
2413                 }
2414                 cx->blk_sub.cv = cv;
2415                 cx->blk_sub.olddepth = CvDEPTH(cv);
2416
2417                 CvDEPTH(cv)++;
2418                 if (CvDEPTH(cv) < 2)
2419                     SvREFCNT_inc_simple_void_NN(cv);
2420                 else {
2421                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2422                         sub_crush_depth(cv);
2423                     pad_push(padlist, CvDEPTH(cv));
2424                 }
2425                 SAVECOMPPAD();
2426                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2427                 if (cx->blk_sub.hasargs)
2428                 {
2429                     AV* const av = (AV*)PAD_SVl(0);
2430
2431                     cx->blk_sub.savearray = GvAV(PL_defgv);
2432                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2433                     CX_CURPAD_SAVE(cx->blk_sub);
2434                     cx->blk_sub.argarray = av;
2435
2436                     if (items >= AvMAX(av) + 1) {
2437                         SV **ary = AvALLOC(av);
2438                         if (AvARRAY(av) != ary) {
2439                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2440                             AvARRAY(av) = ary;
2441                         }
2442                         if (items >= AvMAX(av) + 1) {
2443                             AvMAX(av) = items - 1;
2444                             Renew(ary,items+1,SV*);
2445                             AvALLOC(av) = ary;
2446                             AvARRAY(av) = ary;
2447                         }
2448                     }
2449                     ++mark;
2450                     Copy(mark,AvARRAY(av),items,SV*);
2451                     AvFILLp(av) = items - 1;
2452                     assert(!AvREAL(av));
2453                     if (reified) {
2454                         /* transfer 'ownership' of refcnts to new @_ */
2455                         AvREAL_on(av);
2456                         AvREIFY_off(av);
2457                     }
2458                     while (items--) {
2459                         if (*mark)
2460                             SvTEMP_off(*mark);
2461                         mark++;
2462                     }
2463                 }
2464                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2465                     Perl_get_db_sub(aTHX_ NULL, cv);
2466                     if (PERLDB_GOTO) {
2467                         CV * const gotocv = get_cv("DB::goto", FALSE);
2468                         if (gotocv) {
2469                             PUSHMARK( PL_stack_sp );
2470                             call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2471                             PL_stack_sp--;
2472                         }
2473                     }
2474                 }
2475                 RETURNOP(CvSTART(cv));
2476             }
2477         }
2478         else {
2479             label = SvPV_nolen_const(sv);
2480             if (!(do_dump || *label))
2481                 DIE(aTHX_ must_have_label);
2482         }
2483     }
2484     else if (PL_op->op_flags & OPf_SPECIAL) {
2485         if (! do_dump)
2486             DIE(aTHX_ must_have_label);
2487     }
2488     else
2489         label = cPVOP->op_pv;
2490
2491     if (label && *label) {
2492         OP *gotoprobe = NULL;
2493         bool leaving_eval = FALSE;
2494         bool in_block = FALSE;
2495         PERL_CONTEXT *last_eval_cx = NULL;
2496
2497         /* find label */
2498
2499         PL_lastgotoprobe = NULL;
2500         *enterops = 0;
2501         for (ix = cxstack_ix; ix >= 0; ix--) {
2502             cx = &cxstack[ix];
2503             switch (CxTYPE(cx)) {
2504             case CXt_EVAL:
2505                 leaving_eval = TRUE;
2506                 if (!CxTRYBLOCK(cx)) {
2507                     gotoprobe = (last_eval_cx ?
2508                                 last_eval_cx->blk_eval.old_eval_root :
2509                                 PL_eval_root);
2510                     last_eval_cx = cx;
2511                     break;
2512                 }
2513                 /* else fall through */
2514             case CXt_LOOP:
2515                 gotoprobe = cx->blk_oldcop->op_sibling;
2516                 break;
2517             case CXt_SUBST:
2518                 continue;
2519             case CXt_BLOCK:
2520                 if (ix) {
2521                     gotoprobe = cx->blk_oldcop->op_sibling;
2522                     in_block = TRUE;
2523                 } else
2524                     gotoprobe = PL_main_root;
2525                 break;
2526             case CXt_SUB:
2527                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2528                     gotoprobe = CvROOT(cx->blk_sub.cv);
2529                     break;
2530                 }
2531                 /* FALL THROUGH */
2532             case CXt_FORMAT:
2533             case CXt_NULL:
2534                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2535             default:
2536                 if (ix)
2537                     DIE(aTHX_ "panic: goto");
2538                 gotoprobe = PL_main_root;
2539                 break;
2540             }
2541             if (gotoprobe) {
2542                 retop = dofindlabel(gotoprobe, label,
2543                                     enterops, enterops + GOTO_DEPTH);
2544                 if (retop)
2545                     break;
2546             }
2547             PL_lastgotoprobe = gotoprobe;
2548         }
2549         if (!retop)
2550             DIE(aTHX_ "Can't find label %s", label);
2551
2552         /* if we're leaving an eval, check before we pop any frames
2553            that we're not going to punt, otherwise the error
2554            won't be caught */
2555
2556         if (leaving_eval && *enterops && enterops[1]) {
2557             I32 i;
2558             for (i = 1; enterops[i]; i++)
2559                 if (enterops[i]->op_type == OP_ENTERITER)
2560                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2561         }
2562
2563         /* pop unwanted frames */
2564
2565         if (ix < cxstack_ix) {
2566             I32 oldsave;
2567
2568             if (ix < 0)
2569                 ix = 0;
2570             dounwind(ix);
2571             TOPBLOCK(cx);
2572             oldsave = PL_scopestack[PL_scopestack_ix];
2573             LEAVE_SCOPE(oldsave);
2574         }
2575
2576         /* push wanted frames */
2577
2578         if (*enterops && enterops[1]) {
2579             OP * const oldop = PL_op;
2580             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2581             for (; enterops[ix]; ix++) {
2582                 PL_op = enterops[ix];
2583                 /* Eventually we may want to stack the needed arguments
2584                  * for each op.  For now, we punt on the hard ones. */
2585                 if (PL_op->op_type == OP_ENTERITER)
2586                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2587                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2588             }
2589             PL_op = oldop;
2590         }
2591     }
2592
2593     if (do_dump) {
2594 #ifdef VMS
2595         if (!retop) retop = PL_main_start;
2596 #endif
2597         PL_restartop = retop;
2598         PL_do_undump = TRUE;
2599
2600         my_unexec();
2601
2602         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2603         PL_do_undump = FALSE;
2604     }
2605
2606     RETURNOP(retop);
2607 }
2608
2609 PP(pp_exit)
2610 {
2611     dVAR;
2612     dSP;
2613     I32 anum;
2614
2615     if (MAXARG < 1)
2616         anum = 0;
2617     else {
2618         anum = SvIVx(POPs);
2619 #ifdef VMS
2620         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2621             anum = 0;
2622         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2623 #endif
2624     }
2625     PL_exit_flags |= PERL_EXIT_EXPECTED;
2626 #ifdef PERL_MAD
2627     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2628     if (anum || !(PL_minus_c && PL_madskills))
2629         my_exit(anum);
2630 #else
2631     my_exit(anum);
2632 #endif
2633     PUSHs(&PL_sv_undef);
2634     RETURN;
2635 }
2636
2637 /* Eval. */
2638
2639 STATIC void
2640 S_save_lines(pTHX_ AV *array, SV *sv)
2641 {
2642     const char *s = SvPVX_const(sv);
2643     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2644     I32 line = 1;
2645
2646     while (s && s < send) {
2647         const char *t;
2648         SV * const tmpstr = newSV_type(SVt_PVMG);
2649
2650         t = strchr(s, '\n');
2651         if (t)
2652             t++;
2653         else
2654             t = send;
2655
2656         sv_setpvn(tmpstr, s, t - s);
2657         av_store(array, line++, tmpstr);
2658         s = t;
2659     }
2660 }
2661
2662 STATIC OP *
2663 S_docatch(pTHX_ OP *o)
2664 {
2665     dVAR;
2666     int ret;
2667     OP * const oldop = PL_op;
2668     dJMPENV;
2669
2670 #ifdef DEBUGGING
2671     assert(CATCH_GET == TRUE);
2672 #endif
2673     PL_op = o;
2674
2675     JMPENV_PUSH(ret);
2676     switch (ret) {
2677     case 0:
2678         assert(cxstack_ix >= 0);
2679         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2680         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2681  redo_body:
2682         CALLRUNOPS(aTHX);
2683         break;
2684     case 3:
2685         /* die caught by an inner eval - continue inner loop */
2686
2687         /* NB XXX we rely on the old popped CxEVAL still being at the top
2688          * of the stack; the way die_where() currently works, this
2689          * assumption is valid. In theory The cur_top_env value should be
2690          * returned in another global, the way retop (aka PL_restartop)
2691          * is. */
2692         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2693
2694         if (PL_restartop
2695             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2696         {
2697             PL_op = PL_restartop;
2698             PL_restartop = 0;
2699             goto redo_body;
2700         }
2701         /* FALL THROUGH */
2702     default:
2703         JMPENV_POP;
2704         PL_op = oldop;
2705         JMPENV_JUMP(ret);
2706         /* NOTREACHED */
2707     }
2708     JMPENV_POP;
2709     PL_op = oldop;
2710     return NULL;
2711 }
2712
2713 OP *
2714 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2715 /* sv Text to convert to OP tree. */
2716 /* startop op_free() this to undo. */
2717 /* code Short string id of the caller. */
2718 {
2719     /* FIXME - how much of this code is common with pp_entereval?  */
2720     dVAR; dSP;                          /* Make POPBLOCK work. */
2721     PERL_CONTEXT *cx;
2722     SV **newsp;
2723     I32 gimme = G_VOID;
2724     I32 optype;
2725     OP dummy;
2726     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2727     char *tmpbuf = tbuf;
2728     char *safestr;
2729     int runtime;
2730     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2731     STRLEN len;
2732
2733     ENTER;
2734     lex_start(sv, NULL, FALSE);
2735     SAVETMPS;
2736     /* switch to eval mode */
2737
2738     if (IN_PERL_COMPILETIME) {
2739         SAVECOPSTASH_FREE(&PL_compiling);
2740         CopSTASH_set(&PL_compiling, PL_curstash);
2741     }
2742     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2743         SV * const sv = sv_newmortal();
2744         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2745                        code, (unsigned long)++PL_evalseq,
2746                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2747         tmpbuf = SvPVX(sv);
2748         len = SvCUR(sv);
2749     }
2750     else
2751         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2752                           (unsigned long)++PL_evalseq);
2753     SAVECOPFILE_FREE(&PL_compiling);
2754     CopFILE_set(&PL_compiling, tmpbuf+2);
2755     SAVECOPLINE(&PL_compiling);
2756     CopLINE_set(&PL_compiling, 1);
2757     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2758        deleting the eval's FILEGV from the stash before gv_check() runs
2759        (i.e. before run-time proper). To work around the coredump that
2760        ensues, we always turn GvMULTI_on for any globals that were
2761        introduced within evals. See force_ident(). GSAR 96-10-12 */
2762     safestr = savepvn(tmpbuf, len);
2763     SAVEDELETE(PL_defstash, safestr, len);
2764     SAVEHINTS();
2765 #ifdef OP_IN_REGISTER
2766     PL_opsave = op;
2767 #else
2768     SAVEVPTR(PL_op);
2769 #endif
2770
2771     /* we get here either during compilation, or via pp_regcomp at runtime */
2772     runtime = IN_PERL_RUNTIME;
2773     if (runtime)
2774         runcv = find_runcv(NULL);
2775
2776     PL_op = &dummy;
2777     PL_op->op_type = OP_ENTEREVAL;
2778     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2779     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2780     PUSHEVAL(cx, 0, NULL);
2781
2782     if (runtime)
2783         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2784     else
2785         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2786     POPBLOCK(cx,PL_curpm);
2787     POPEVAL(cx);
2788
2789     (*startop)->op_type = OP_NULL;
2790     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2791     lex_end();
2792     /* XXX DAPM do this properly one year */
2793     *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2794     LEAVE;
2795     if (IN_PERL_COMPILETIME)
2796         CopHINTS_set(&PL_compiling, PL_hints);
2797 #ifdef OP_IN_REGISTER
2798     op = PL_opsave;
2799 #endif
2800     PERL_UNUSED_VAR(newsp);
2801     PERL_UNUSED_VAR(optype);
2802
2803     return PL_eval_start;
2804 }
2805
2806
2807 /*
2808 =for apidoc find_runcv
2809
2810 Locate the CV corresponding to the currently executing sub or eval.
2811 If db_seqp is non_null, skip CVs that are in the DB package and populate
2812 *db_seqp with the cop sequence number at the point that the DB:: code was
2813 entered. (allows debuggers to eval in the scope of the breakpoint rather
2814 than in the scope of the debugger itself).
2815
2816 =cut
2817 */
2818
2819 CV*
2820 Perl_find_runcv(pTHX_ U32 *db_seqp)
2821 {
2822     dVAR;
2823     PERL_SI      *si;
2824
2825     if (db_seqp)
2826         *db_seqp = PL_curcop->cop_seq;
2827     for (si = PL_curstackinfo; si; si = si->si_prev) {
2828         I32 ix;
2829         for (ix = si->si_cxix; ix >= 0; ix--) {
2830             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2831             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2832                 CV * const cv = cx->blk_sub.cv;
2833                 /* skip DB:: code */
2834                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2835                     *db_seqp = cx->blk_oldcop->cop_seq;
2836                     continue;
2837                 }
2838                 return cv;
2839             }
2840             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2841                 return PL_compcv;
2842         }
2843     }
2844     return PL_main_cv;
2845 }
2846
2847
2848 /* Compile a require/do, an eval '', or a /(?{...})/.
2849  * In the last case, startop is non-null, and contains the address of
2850  * a pointer that should be set to the just-compiled code.
2851  * outside is the lexically enclosing CV (if any) that invoked us.
2852  * Returns a bool indicating whether the compile was successful; if so,
2853  * PL_eval_start contains the first op of the compiled ocde; otherwise,
2854  * pushes undef (also croaks if startop != NULL).
2855  */
2856
2857 STATIC bool
2858 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2859 {
2860     dVAR; dSP;
2861     OP * const saveop = PL_op;
2862
2863     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2864                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2865                   : EVAL_INEVAL);
2866
2867     PUSHMARK(SP);
2868
2869     SAVESPTR(PL_compcv);
2870     PL_compcv = (CV*)newSV_type(SVt_PVCV);
2871     CvEVAL_on(PL_compcv);
2872     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2873     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2874
2875     CvOUTSIDE_SEQ(PL_compcv) = seq;
2876     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2877
2878     /* set up a scratch pad */
2879
2880     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2881     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2882
2883
2884     if (!PL_madskills)
2885         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
2886
2887     /* make sure we compile in the right package */
2888
2889     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2890         SAVESPTR(PL_curstash);
2891         PL_curstash = CopSTASH(PL_curcop);
2892     }
2893     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2894     SAVESPTR(PL_beginav);
2895     PL_beginav = newAV();
2896     SAVEFREESV(PL_beginav);
2897     SAVESPTR(PL_unitcheckav);
2898     PL_unitcheckav = newAV();
2899     SAVEFREESV(PL_unitcheckav);
2900
2901 #ifdef PERL_MAD
2902     SAVEBOOL(PL_madskills);
2903     PL_madskills = 0;
2904 #endif
2905
2906     /* try to compile it */
2907
2908     PL_eval_root = NULL;
2909     PL_curcop = &PL_compiling;
2910     CopARYBASE_set(PL_curcop, 0);
2911     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2912         PL_in_eval |= EVAL_KEEPERR;
2913     else
2914         sv_setpvn(ERRSV,"",0);
2915     if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2916         SV **newsp;                     /* Used by POPBLOCK. */
2917         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2918         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2919         const char *msg;
2920
2921         PL_op = saveop;
2922         if (PL_eval_root) {
2923             op_free(PL_eval_root);
2924             PL_eval_root = NULL;
2925         }
2926         SP = PL_stack_base + POPMARK;           /* pop original mark */
2927         if (!startop) {
2928             POPBLOCK(cx,PL_curpm);
2929             POPEVAL(cx);
2930         }
2931         lex_end();
2932         LEAVE;
2933
2934         msg = SvPVx_nolen_const(ERRSV);
2935         if (optype == OP_REQUIRE) {
2936             const SV * const nsv = cx->blk_eval.old_namesv;
2937             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2938                           &PL_sv_undef, 0);
2939             Perl_croak(aTHX_ "%sCompilation failed in require",
2940                        *msg ? msg : "Unknown error\n");
2941         }
2942         else if (startop) {
2943             POPBLOCK(cx,PL_curpm);
2944             POPEVAL(cx);
2945             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2946                        (*msg ? msg : "Unknown error\n"));
2947         }
2948         else {
2949             if (!*msg) {
2950                 sv_setpvs(ERRSV, "Compilation error");
2951             }
2952         }
2953         PERL_UNUSED_VAR(newsp);
2954         PUSHs(&PL_sv_undef);
2955         PUTBACK;
2956         return FALSE;
2957     }
2958     CopLINE_set(&PL_compiling, 0);
2959     if (startop) {
2960         *startop = PL_eval_root;
2961     } else
2962         SAVEFREEOP(PL_eval_root);
2963
2964     /* Set the context for this new optree.
2965      * If the last op is an OP_REQUIRE, force scalar context.
2966      * Otherwise, propagate the context from the eval(). */
2967     if (PL_eval_root->op_type == OP_LEAVEEVAL
2968             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2969             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2970             == OP_REQUIRE)
2971         scalar(PL_eval_root);
2972     else if (gimme & G_VOID)
2973         scalarvoid(PL_eval_root);
2974     else if (gimme & G_ARRAY)
2975         list(PL_eval_root);
2976     else
2977         scalar(PL_eval_root);
2978
2979     DEBUG_x(dump_eval());
2980
2981     /* Register with debugger: */
2982     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2983         CV * const cv = get_cv("DB::postponed", FALSE);
2984         if (cv) {
2985             dSP;
2986             PUSHMARK(SP);
2987             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2988             PUTBACK;
2989             call_sv((SV*)cv, G_DISCARD);
2990         }
2991     }
2992
2993     if (PL_unitcheckav)
2994         call_list(PL_scopestack_ix, PL_unitcheckav);
2995
2996     /* compiled okay, so do it */
2997
2998     CvDEPTH(PL_compcv) = 1;
2999     SP = PL_stack_base + POPMARK;               /* pop original mark */
3000     PL_op = saveop;                     /* The caller may need it. */
3001     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3002
3003     PUTBACK;
3004     return TRUE;
3005 }
3006
3007 STATIC PerlIO *
3008 S_check_type_and_open(pTHX_ const char *name)
3009 {
3010     Stat_t st;
3011     const int st_rc = PerlLIO_stat(name, &st);
3012
3013     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3014         return NULL;
3015     }
3016
3017     return PerlIO_open(name, PERL_SCRIPT_MODE);
3018 }
3019
3020 #ifndef PERL_DISABLE_PMC
3021 STATIC PerlIO *
3022 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3023 {
3024     PerlIO *fp;
3025
3026     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3027         SV *const pmcsv = newSV(namelen + 2);
3028         char *const pmc = SvPVX(pmcsv);
3029         Stat_t pmcstat;
3030
3031         memcpy(pmc, name, namelen);
3032         pmc[namelen] = 'c';
3033         pmc[namelen + 1] = '\0';
3034
3035         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3036             fp = check_type_and_open(name);
3037         }
3038         else {
3039             fp = check_type_and_open(pmc);
3040         }
3041         SvREFCNT_dec(pmcsv);
3042     }
3043     else {
3044         fp = check_type_and_open(name);
3045     }
3046     return fp;
3047 }
3048 #else
3049 #  define doopen_pm(name, namelen) check_type_and_open(name)
3050 #endif /* !PERL_DISABLE_PMC */
3051
3052 PP(pp_require)
3053 {
3054     dVAR; dSP;
3055     register PERL_CONTEXT *cx;
3056     SV *sv;
3057     const char *name;
3058     STRLEN len;
3059     char * unixname;
3060     STRLEN unixlen;
3061 #ifdef VMS
3062     int vms_unixname = 0;
3063 #endif
3064     const char *tryname = NULL;
3065     SV *namesv = NULL;
3066     const I32 gimme = GIMME_V;
3067     int filter_has_file = 0;
3068     PerlIO *tryrsfp = NULL;
3069     SV *filter_cache = NULL;
3070     SV *filter_state = NULL;
3071     SV *filter_sub = NULL;
3072     SV *hook_sv = NULL;
3073     SV *encoding;
3074     OP *op;
3075
3076     sv = POPs;
3077     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3078         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) {     /* require v5.6.1 */
3079             HV * hinthv = GvHV(PL_hintgv);
3080             SV ** ptr = NULL;
3081             if (hinthv) ptr = hv_fetchs(hinthv, "v_string", FALSE);
3082             if ( !(ptr && *ptr && SvIOK(*ptr) && SvIV(*ptr)) )
3083                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3084                         "v-string in use/require non-portable");
3085         }
3086         sv = new_version(sv);
3087         if (!sv_derived_from(PL_patchlevel, "version"))
3088             upg_version(PL_patchlevel, TRUE);
3089         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3090             if ( vcmp(sv,PL_patchlevel) <= 0 )
3091                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3092                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3093         }
3094         else {
3095             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3096                 I32 first = 0;
3097                 AV *lav;
3098                 SV * const req = SvRV(sv);
3099                 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3100
3101                 /* get the left hand term */
3102                 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3103
3104                 first  = SvIV(*av_fetch(lav,0,0));
3105                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3106                     || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3107                     || av_len(lav) > 1               /* FP with > 3 digits */
3108                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3109                    ) {
3110                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3111                         "%"SVf", stopped", SVfARG(vnormal(req)),
3112                         SVfARG(vnormal(PL_patchlevel)));
3113                 }
3114                 else { /* probably 'use 5.10' or 'use 5.8' */
3115                     SV * hintsv = newSV(0);
3116                     I32 second = 0;
3117
3118                     if (av_len(lav)>=1)
3119                         second = SvIV(*av_fetch(lav,1,0));
3120
3121                     second /= second >= 600  ? 100 : 10;
3122                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3123                         (int)first, (int)second,0);
3124                     upg_version(hintsv, TRUE);
3125
3126                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3127                         "--this is only %"SVf", stopped",
3128                         SVfARG(vnormal(req)),
3129                         SVfARG(vnormal(hintsv)),
3130                         SVfARG(vnormal(PL_patchlevel)));
3131                 }
3132             }
3133         }
3134
3135         /* We do this only with use, not require. */
3136         if (PL_compcv &&
3137           /* If we request a version >= 5.6.0, then v-string are OK
3138              so set $^H{v_string} to suppress the v-string warning */
3139             vcmp(sv, sv_2mortal(upg_version(newSVnv(5.006), FALSE))) >= 0) {
3140           HV * hinthv = GvHV(PL_hintgv);
3141           if( hinthv ) {
3142               SV *hint = newSViv(1);
3143               (void)hv_stores(hinthv, "v_string", hint);
3144               /* This will call through to Perl_magic_sethint() which in turn
3145                  sets PL_hints correctly.  */
3146               SvSETMAGIC(hint);
3147           }
3148           /* If we request a version >= 5.9.5, load feature.pm with the
3149            * feature bundle that corresponds to the required version. */
3150           if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3151             SV *const importsv = vnormal(sv);
3152             *SvPVX_mutable(importsv) = ':';
3153             ENTER;
3154             Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3155             LEAVE;
3156           }
3157         }
3158
3159         RETPUSHYES;
3160     }
3161     name = SvPV_const(sv, len);
3162     if (!(name && len > 0 && *name))
3163         DIE(aTHX_ "Null filename used");
3164     TAINT_PROPER("require");
3165
3166
3167 #ifdef VMS
3168     /* The key in the %ENV hash is in the syntax of file passed as the argument
3169      * usually this is in UNIX format, but sometimes in VMS format, which
3170      * can result in a module being pulled in more than once.
3171      * To prevent this, the key must be stored in UNIX format if the VMS
3172      * name can be translated to UNIX.
3173      */
3174     if ((unixname = tounixspec(name, NULL)) != NULL) {
3175         unixlen = strlen(unixname);
3176         vms_unixname = 1;
3177     }
3178     else
3179 #endif
3180     {
3181         /* if not VMS or VMS name can not be translated to UNIX, pass it
3182          * through.
3183          */
3184         unixname = (char *) name;
3185         unixlen = len;
3186     }
3187     if (PL_op->op_type == OP_REQUIRE) {
3188         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3189                                           unixname, unixlen, 0);
3190         if ( svp ) {
3191             if (*svp != &PL_sv_undef)
3192                 RETPUSHYES;
3193             else
3194                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3195                             "Compilation failed in require", unixname);
3196         }
3197     }
3198
3199     /* prepare to compile file */
3200
3201     if (path_is_absolute(name)) {
3202         tryname = name;
3203         tryrsfp = doopen_pm(name, len);
3204     }
3205 #ifdef MACOS_TRADITIONAL
3206     if (!tryrsfp) {
3207         char newname[256];
3208
3209         MacPerl_CanonDir(name, newname, 1);
3210         if (path_is_absolute(newname)) {
3211             tryname = newname;
3212             tryrsfp = doopen_pm(newname, strlen(newname));
3213         }
3214     }
3215 #endif
3216     if (!tryrsfp) {
3217         AV * const ar = GvAVn(PL_incgv);
3218         I32 i;
3219 #ifdef VMS
3220         if (vms_unixname)
3221 #endif
3222         {
3223             namesv = newSV(0);
3224             sv_upgrade(namesv, SVt_PV);
3225             for (i = 0; i <= AvFILL(ar); i++) {
3226                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3227
3228                 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3229                     mg_get(dirsv);
3230                 if (SvROK(dirsv)) {
3231                     int count;
3232                     SV **svp;
3233                     SV *loader = dirsv;
3234
3235                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3236                         && !sv_isobject(loader))
3237                     {
3238                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3239                     }
3240
3241                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3242                                    PTR2UV(SvRV(dirsv)), name);
3243                     tryname = SvPVX_const(namesv);
3244                     tryrsfp = NULL;
3245
3246                     ENTER;
3247                     SAVETMPS;
3248                     EXTEND(SP, 2);
3249
3250                     PUSHMARK(SP);
3251                     PUSHs(dirsv);
3252                     PUSHs(sv);
3253                     PUTBACK;
3254                     if (sv_isobject(loader))
3255                         count = call_method("INC", G_ARRAY);
3256                     else
3257                         count = call_sv(loader, G_ARRAY);
3258                     SPAGAIN;
3259
3260                     /* Adjust file name if the hook has set an %INC entry */
3261                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3262                     if (svp)
3263                         tryname = SvPVX_const(*svp);
3264
3265                     if (count > 0) {
3266                         int i = 0;
3267                         SV *arg;
3268
3269                         SP -= count - 1;
3270                         arg = SP[i++];
3271
3272                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3273                             && !isGV_with_GP(SvRV(arg))) {
3274                             filter_cache = SvRV(arg);
3275                             SvREFCNT_inc_simple_void_NN(filter_cache);
3276
3277                             if (i < count) {
3278                                 arg = SP[i++];
3279                             }
3280                         }
3281
3282                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3283                             arg = SvRV(arg);
3284                         }
3285
3286                         if (SvTYPE(arg) == SVt_PVGV) {
3287                             IO * const io = GvIO((GV *)arg);
3288
3289                             ++filter_has_file;
3290
3291                             if (io) {
3292                                 tryrsfp = IoIFP(io);
3293                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3294                                     PerlIO_close(IoOFP(io));
3295                                 }
3296                                 IoIFP(io) = NULL;
3297                                 IoOFP(io) = NULL;
3298                             }
3299
3300                             if (i < count) {
3301                                 arg = SP[i++];
3302                             }
3303                         }
3304
3305                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3306                             filter_sub = arg;
3307                             SvREFCNT_inc_simple_void_NN(filter_sub);
3308
3309                             if (i < count) {
3310                                 filter_state = SP[i];
3311                                 SvREFCNT_inc_simple_void(filter_state);
3312                             }
3313                         }
3314
3315                         if (!tryrsfp && (filter_cache || filter_sub)) {
3316                             tryrsfp = PerlIO_open(BIT_BUCKET,
3317                                                   PERL_SCRIPT_MODE);
3318                         }
3319                         SP--;
3320                     }
3321
3322                     PUTBACK;
3323                     FREETMPS;
3324                     LEAVE;
3325
3326                     if (tryrsfp) {
3327                         hook_sv = dirsv;
3328                         break;
3329                     }
3330
3331                     filter_has_file = 0;
3332                     if (filter_cache) {
3333                         SvREFCNT_dec(filter_cache);
3334                         filter_cache = NULL;
3335                     }
3336                     if (filter_state) {
3337                         SvREFCNT_dec(filter_state);
3338                         filter_state = NULL;
3339                     }
3340                     if (filter_sub) {
3341                         SvREFCNT_dec(filter_sub);
3342                         filter_sub = NULL;
3343                     }
3344                 }
3345                 else {
3346                   if (!path_is_absolute(name)
3347 #ifdef MACOS_TRADITIONAL
3348                         /* We consider paths of the form :a:b ambiguous and interpret them first
3349                            as global then as local
3350                         */
3351                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3352 #endif
3353                   ) {
3354                     const char *dir;
3355                     STRLEN dirlen;
3356
3357                     if (SvOK(dirsv)) {
3358                         dir = SvPV_const(dirsv, dirlen);
3359                     } else {
3360                         dir = "";
3361                         dirlen = 0;
3362                     }
3363
3364 #ifdef MACOS_TRADITIONAL
3365                     char buf1[256];
3366                     char buf2[256];
3367
3368                     MacPerl_CanonDir(name, buf2, 1);
3369                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3370 #else
3371 #  ifdef VMS
3372                     char *unixdir;
3373                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3374                         continue;
3375                     sv_setpv(namesv, unixdir);
3376                     sv_catpv(namesv, unixname);
3377 #  else
3378 #    ifdef __SYMBIAN32__
3379                     if (PL_origfilename[0] &&
3380                         PL_origfilename[1] == ':' &&
3381                         !(dir[0] && dir[1] == ':'))
3382                         Perl_sv_setpvf(aTHX_ namesv,
3383                                        "%c:%s\\%s",
3384                                        PL_origfilename[0],
3385                                        dir, name);
3386                     else
3387                         Perl_sv_setpvf(aTHX_ namesv,
3388                                        "%s\\%s",
3389                                        dir, name);
3390 #    else
3391                     /* The equivalent of
3392                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3393                        but without the need to parse the format string, or
3394                        call strlen on either pointer, and with the correct
3395                        allocation up front.  */
3396                     {
3397                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3398
3399                         memcpy(tmp, dir, dirlen);
3400                         tmp +=dirlen;
3401                         *tmp++ = '/';
3402                         /* name came from an SV, so it will have a '\0' at the
3403                            end that we can copy as part of this memcpy().  */
3404                         memcpy(tmp, name, len + 1);
3405
3406                         SvCUR_set(namesv, dirlen + len + 1);
3407
3408                         /* Don't even actually have to turn SvPOK_on() as we
3409                            access it directly with SvPVX() below.  */
3410                     }
3411 #    endif
3412 #  endif
3413 #endif
3414                     TAINT_PROPER("require");
3415                     tryname = SvPVX_const(namesv);
3416                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3417                     if (tryrsfp) {
3418                         if (tryname[0] == '.' && tryname[1] == '/')
3419                             tryname += 2;
3420                         break;
3421                     }
3422                     else if (errno == EMFILE)
3423                         /* no point in trying other paths if out of handles */
3424                         break;
3425                   }
3426                 }
3427             }
3428         }
3429     }
3430     SAVECOPFILE_FREE(&PL_compiling);
3431     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3432     SvREFCNT_dec(namesv);
3433     if (!tryrsfp) {
3434         if (PL_op->op_type == OP_REQUIRE) {
3435             const char *msgstr = name;
3436             if(errno == EMFILE) {
3437                 SV * const msg
3438                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3439                                                Strerror(errno)));
3440                 msgstr = SvPV_nolen_const(msg);
3441             } else {
3442                 if (namesv) {                   /* did we lookup @INC? */
3443                     AV * const ar = GvAVn(PL_incgv);
3444                     I32 i;
3445                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3446                         "%s in @INC%s%s (@INC contains:",
3447                         msgstr,
3448                         (instr(msgstr, ".h ")
3449                          ? " (change .h to .ph maybe?)" : ""),
3450                         (instr(msgstr, ".ph ")
3451                          ? " (did you run h2ph?)" : "")
3452                                                               ));
3453
3454                     for (i = 0; i <= AvFILL(ar); i++) {
3455                         sv_catpvs(msg, " ");
3456                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3457                     }
3458                     sv_catpvs(msg, ")");
3459                     msgstr = SvPV_nolen_const(msg);
3460                 }
3461             }
3462             DIE(aTHX_ "Can't locate %s", msgstr);
3463         }
3464
3465         RETPUSHUNDEF;
3466     }
3467     else
3468         SETERRNO(0, SS_NORMAL);
3469
3470     /* Assume success here to prevent recursive requirement. */
3471     /* name is never assigned to again, so len is still strlen(name)  */
3472     /* Check whether a hook in @INC has already filled %INC */
3473     if (!hook_sv) {
3474         (void)hv_store(GvHVn(PL_incgv),
3475                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3476     } else {
3477         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3478         if (!svp)
3479             (void)hv_store(GvHVn(PL_incgv),
3480                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3481     }
3482
3483     ENTER;
3484     SAVETMPS;
3485     lex_start(NULL, tryrsfp, TRUE);
3486
3487     SAVEHINTS();
3488     PL_hints = 0;
3489     SAVECOMPILEWARNINGS();
3490     if (PL_dowarn & G_WARN_ALL_ON)
3491         PL_compiling.cop_warnings = pWARN_ALL ;
3492     else if (PL_dowarn & G_WARN_ALL_OFF)
3493         PL_compiling.cop_warnings = pWARN_NONE ;
3494     else
3495         PL_compiling.cop_warnings = pWARN_STD ;
3496
3497     if (filter_sub || filter_cache) {
3498         SV * const datasv = filter_add(S_run_user_filter, NULL);
3499         IoLINES(datasv) = filter_has_file;
3500         IoTOP_GV(datasv) = (GV *)filter_state;
3501         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3502         IoFMT_GV(datasv) = (GV *)filter_cache;
3503     }
3504
3505     /* switch to eval mode */
3506     PUSHBLOCK(cx, CXt_EVAL, SP);
3507     PUSHEVAL(cx, name, NULL);
3508     cx->blk_eval.retop = PL_op->op_next;
3509
3510     SAVECOPLINE(&PL_compiling);
3511     CopLINE_set(&PL_compiling, 0);
3512
3513     PUTBACK;
3514
3515     /* Store and reset encoding. */
3516     encoding = PL_encoding;
3517     PL_encoding = NULL;
3518
3519     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3520         op = DOCATCH(PL_eval_start);
3521     else
3522         op = PL_op->op_next;
3523
3524     /* Restore encoding. */
3525     PL_encoding = encoding;
3526
3527     return op;
3528 }
3529
3530 PP(pp_entereval)
3531 {
3532     dVAR; dSP;
3533     register PERL_CONTEXT *cx;
3534     SV *sv;
3535     const I32 gimme = GIMME_V;
3536     const I32 was = PL_sub_generation;
3537     char tbuf[TYPE_DIGITS(long) + 12];
3538     char *tmpbuf = tbuf;
3539     char *safestr;
3540     STRLEN len;
3541     bool ok;
3542     CV* runcv;
3543     U32 seq;
3544     HV *saved_hh = NULL;
3545     const char * const fakestr = "_<(eval )";
3546     const int fakelen = 9 + 1;
3547
3548     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3549         saved_hh = (HV*) SvREFCNT_inc(POPs);
3550     }
3551     sv = POPs;
3552
3553     TAINT_IF(SvTAINTED(sv));
3554     TAINT_PROPER("eval");
3555
3556     ENTER;
3557     lex_start(sv, NULL, FALSE);
3558     SAVETMPS;
3559
3560     /* switch to eval mode */
3561
3562     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3563         SV * const temp_sv = sv_newmortal();
3564         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3565                        (unsigned long)++PL_evalseq,
3566                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3567         tmpbuf = SvPVX(temp_sv);
3568         len = SvCUR(temp_sv);
3569     }
3570     else
3571         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3572     SAVECOPFILE_FREE(&PL_compiling);
3573     CopFILE_set(&PL_compiling, tmpbuf+2);
3574     SAVECOPLINE(&PL_compiling);
3575     CopLINE_set(&PL_compiling, 1);
3576     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3577        deleting the eval's FILEGV from the stash before gv_check() runs
3578        (i.e. before run-time proper). To work around the coredump that
3579        ensues, we always turn GvMULTI_on for any globals that were
3580        introduced within evals. See force_ident(). GSAR 96-10-12 */
3581     safestr = savepvn(tmpbuf, len);
3582     SAVEDELETE(PL_defstash, safestr, len);
3583     SAVEHINTS();
3584     PL_hints = PL_op->op_targ;
3585     if (saved_hh)
3586         GvHV(PL_hintgv) = saved_hh;
3587     SAVECOMPILEWARNINGS();
3588     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3589     if (PL_compiling.cop_hints_hash) {
3590         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3591     }
3592     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3593     if (PL_compiling.cop_hints_hash) {
3594         HINTS_REFCNT_LOCK;
3595         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3596         HINTS_REFCNT_UNLOCK;
3597     }
3598     /* special case: an eval '' executed within the DB package gets lexically
3599      * placed in the first non-DB CV rather than the current CV - this
3600      * allows the debugger to execute code, find lexicals etc, in the
3601      * scope of the code being debugged. Passing &seq gets find_runcv
3602      * to do the dirty work for us */
3603     runcv = find_runcv(&seq);
3604
3605     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3606     PUSHEVAL(cx, 0, NULL);
3607     cx->blk_eval.retop = PL_op->op_next;
3608
3609     /* prepare to compile string */
3610
3611     if (PERLDB_LINE && PL_curstash != PL_debstash)
3612         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3613     PUTBACK;
3614     ok = doeval(gimme, NULL, runcv, seq);
3615     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3616         && ok) {
3617         /* Copy in anything fake and short. */
3618         my_strlcpy(safestr, fakestr, fakelen);
3619     }
3620     return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3621 }
3622
3623 PP(pp_leaveeval)
3624 {
3625     dVAR; dSP;
3626     register SV **mark;
3627     SV **newsp;
3628     PMOP *newpm;
3629     I32 gimme;
3630     register PERL_CONTEXT *cx;
3631     OP *retop;
3632     const U8 save_flags = PL_op -> op_flags;
3633     I32 optype;
3634
3635     POPBLOCK(cx,newpm);
3636     POPEVAL(cx);
3637     retop = cx->blk_eval.retop;
3638
3639     TAINT_NOT;
3640     if (gimme == G_VOID)
3641         MARK = newsp;
3642     else if (gimme == G_SCALAR) {
3643         MARK = newsp + 1;
3644         if (MARK <= SP) {
3645             if (SvFLAGS(TOPs) & SVs_TEMP)
3646                 *MARK = TOPs;
3647             else
3648                 *MARK = sv_mortalcopy(TOPs);
3649         }
3650         else {
3651             MEXTEND(mark,0);
3652             *MARK = &PL_sv_undef;
3653         }
3654         SP = MARK;
3655     }
3656     else {
3657         /* in case LEAVE wipes old return values */
3658         for (mark = newsp + 1; mark <= SP; mark++) {
3659             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3660                 *mark = sv_mortalcopy(*mark);
3661                 TAINT_NOT;      /* Each item is independent */
3662             }
3663         }
3664     }
3665     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3666
3667 #ifdef DEBUGGING
3668     assert(CvDEPTH(PL_compcv) == 1);
3669 #endif
3670     CvDEPTH(PL_compcv) = 0;
3671     lex_end();
3672
3673     if (optype == OP_REQUIRE &&
3674         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3675     {
3676         /* Unassume the success we assumed earlier. */
3677         SV * const nsv = cx->blk_eval.old_namesv;
3678         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3679         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3680         /* die_where() did LEAVE, or we won't be here */
3681     }
3682     else {
3683         LEAVE;
3684         if (!(save_flags & OPf_SPECIAL))
3685             sv_setpvn(ERRSV,"",0);
3686     }
3687
3688     RETURNOP(retop);
3689 }
3690
3691 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3692    close to the related Perl_create_eval_scope.  */
3693 void
3694 Perl_delete_eval_scope(pTHX)
3695 {
3696     SV **newsp;
3697     PMOP *newpm;
3698     I32 gimme;
3699     register PERL_CONTEXT *cx;
3700     I32 optype;
3701
3702     POPBLOCK(cx,newpm);
3703     POPEVAL(cx);
3704     PL_curpm = newpm;
3705     LEAVE;
3706     PERL_UNUSED_VAR(newsp);
3707     PERL_UNUSED_VAR(gimme);
3708     PERL_UNUSED_VAR(optype);
3709 }
3710
3711 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3712    also needed by Perl_fold_constants.  */
3713 PERL_CONTEXT *
3714 Perl_create_eval_scope(pTHX_ U32 flags)
3715 {
3716     PERL_CONTEXT *cx;
3717     const I32 gimme = GIMME_V;
3718
3719     ENTER;
3720     SAVETMPS;
3721
3722     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3723     PUSHEVAL(cx, 0, 0);
3724
3725     PL_in_eval = EVAL_INEVAL;
3726     if (flags & G_KEEPERR)
3727         PL_in_eval |= EVAL_KEEPERR;
3728     else
3729         sv_setpvn(ERRSV,"",0);
3730     if (flags & G_FAKINGEVAL) {
3731         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3732     }
3733     return cx;
3734 }
3735
3736 PP(pp_entertry)
3737 {
3738     dVAR;
3739     PERL_CONTEXT * const cx = create_eval_scope(0);
3740     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3741     return DOCATCH(PL_op->op_next);
3742 }
3743
3744 PP(pp_leavetry)
3745 {
3746     dVAR; dSP;
3747     SV **newsp;
3748     PMOP *newpm;
3749     I32 gimme;
3750     register PERL_CONTEXT *cx;
3751     I32 optype;
3752
3753     POPBLOCK(cx,newpm);
3754     POPEVAL(cx);
3755     PERL_UNUSED_VAR(optype);
3756
3757     TAINT_NOT;
3758     if (gimme == G_VOID)
3759         SP = newsp;
3760     else if (gimme == G_SCALAR) {
3761         register SV **mark;
3762         MARK = newsp + 1;
3763         if (MARK <= SP) {
3764             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3765                 *MARK = TOPs;
3766             else
3767                 *MARK = sv_mortalcopy(TOPs);
3768         }
3769         else {
3770             MEXTEND(mark,0);
3771             *MARK = &PL_sv_undef;
3772         }
3773         SP = MARK;
3774     }
3775     else {
3776         /* in case LEAVE wipes old return values */
3777         register SV **mark;
3778         for (mark = newsp + 1; mark <= SP; mark++) {
3779             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3780                 *mark = sv_mortalcopy(*mark);
3781                 TAINT_NOT;      /* Each item is independent */
3782             }
3783         }
3784     }
3785     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3786
3787     LEAVE;
3788     sv_setpvn(ERRSV,"",0);
3789     RETURN;
3790 }
3791
3792 PP(pp_entergiven)
3793 {
3794     dVAR; dSP;
3795     register PERL_CONTEXT *cx;
3796     const I32 gimme = GIMME_V;
3797
3798     ENTER;
3799     SAVETMPS;
3800
3801     if (PL_op->op_targ == 0) {
3802         SV ** const defsv_p = &GvSV(PL_defgv);
3803         *defsv_p = newSVsv(POPs);
3804         SAVECLEARSV(*defsv_p);
3805     }
3806     else
3807         sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3808
3809     PUSHBLOCK(cx, CXt_GIVEN, SP);
3810     PUSHGIVEN(cx);
3811
3812     RETURN;
3813 }
3814
3815 PP(pp_leavegiven)
3816 {
3817     dVAR; dSP;
3818     register PERL_CONTEXT *cx;
3819     I32 gimme;
3820     SV **newsp;
3821     PMOP *newpm;
3822     PERL_UNUSED_CONTEXT;
3823
3824     POPBLOCK(cx,newpm);
3825     assert(CxTYPE(cx) == CXt_GIVEN);
3826
3827     SP = newsp;
3828     PUTBACK;
3829
3830     PL_curpm = newpm;   /* pop $1 et al */
3831
3832     LEAVE;
3833
3834     return NORMAL;
3835 }
3836
3837 /* Helper routines used by pp_smartmatch */
3838 STATIC PMOP *
3839 S_make_matcher(pTHX_ REGEXP *re)
3840 {
3841     dVAR;
3842     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3843     PM_SETRE(matcher, ReREFCNT_inc(re));
3844
3845     SAVEFREEOP((OP *) matcher);
3846     ENTER; SAVETMPS;
3847     SAVEOP();
3848     return matcher;
3849 }
3850
3851 STATIC bool
3852 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3853 {
3854     dVAR;
3855     dSP;
3856
3857     PL_op = (OP *) matcher;
3858     XPUSHs(sv);
3859     PUTBACK;
3860     (void) pp_match();
3861     SPAGAIN;
3862     return (SvTRUEx(POPs));
3863 }
3864
3865 STATIC void
3866 S_destroy_matcher(pTHX_ PMOP *matcher)
3867 {
3868     dVAR;
3869     PERL_UNUSED_ARG(matcher);
3870     FREETMPS;
3871     LEAVE;
3872 }
3873
3874 /* Do a smart match */
3875 PP(pp_smartmatch)
3876 {
3877     return do_smartmatch(NULL, NULL);
3878 }
3879
3880 /* This version of do_smartmatch() implements the
3881  * table of smart matches that is found in perlsyn.
3882  */
3883 STATIC OP *
3884 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3885 {
3886     dVAR;
3887     dSP;
3888
3889     SV *e = TOPs;       /* e is for 'expression' */
3890     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
3891     SV *This, *Other;   /* 'This' (and Other to match) to play with C++ */
3892     REGEXP *this_regex, *other_regex;
3893
3894 #   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3895
3896 #   define SM_REF(type) ( \
3897            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3898         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3899
3900 #   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
3901         ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV)              \
3902             && NOT_EMPTY_PROTO(This) && (Other = e))                    \
3903         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV)            \
3904             && NOT_EMPTY_PROTO(This) && (Other = d)))
3905
3906 #   define SM_REGEX ( \
3907            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP)          \
3908         && (this_regex = ((struct xregexp *)SvANY(This))->xrx_regexp)   \
3909         && (Other = e))                                                 \
3910     ||                                                                  \
3911            (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP)          \
3912         && (this_regex = ((struct xregexp *)SvANY(This))->xrx_regexp)   \
3913         && (Other = d)) )
3914
3915
3916 #   define SM_OTHER_REF(type) \
3917         (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3918
3919 #   define SM_OTHER_REGEX (SvROK(Other)                                 \
3920         && (SvTYPE(SvRV(Other)) == SVt_REGEXP)                          \
3921         && (other_regex = ((struct xregexp *)SvANY(SvRV(Other)))->xrx_regexp))
3922
3923
3924 #   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3925         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3926
3927 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3928         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3929
3930     tryAMAGICbinSET(smart, 0);
3931
3932     SP -= 2;    /* Pop the values */
3933
3934     /* Take care only to invoke mg_get() once for each argument.
3935      * Currently we do this by copying the SV if it's magical. */
3936     if (d) {
3937         if (SvGMAGICAL(d))
3938             d = sv_mortalcopy(d);
3939     }
3940     else
3941         d = &PL_sv_undef;
3942
3943     assert(e);
3944     if (SvGMAGICAL(e))
3945         e = sv_mortalcopy(e);
3946
3947     if (SM_CV_NEP) {
3948         I32 c;
3949
3950         if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3951         {
3952             if (This == SvRV(Other))
3953                 RETPUSHYES;
3954             else
3955                 RETPUSHNO;
3956         }
3957
3958         ENTER;
3959         SAVETMPS;
3960         PUSHMARK(SP);
3961         PUSHs(Other);
3962         PUTBACK;
3963         c = call_sv(This, G_SCALAR);
3964         SPAGAIN;
3965         if (c == 0)
3966             PUSHs(&PL_sv_no);
3967         else if (SvTEMP(TOPs))
3968             SvREFCNT_inc_void(TOPs);
3969         FREETMPS;
3970         LEAVE;
3971         RETURN;
3972     }
3973     else if (SM_REF(PVHV)) {
3974         if (SM_OTHER_REF(PVHV)) {
3975             /* Check that the key-sets are identical */
3976             HE *he;
3977             HV *other_hv = (HV *) SvRV(Other);
3978             bool tied = FALSE;
3979             bool other_tied = FALSE;
3980             U32 this_key_count  = 0,
3981                 other_key_count = 0;
3982
3983             /* Tied hashes don't know how many keys they have. */
3984             if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3985                 tied = TRUE;
3986             }
3987             else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3988                 HV * const temp = other_hv;
3989                 other_hv = (HV *) This;
3990                 This  = (SV *) temp;
3991                 tied = TRUE;
3992             }
3993             if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3994                 other_tied = TRUE;
3995
3996             if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3997                 RETPUSHNO;
3998
3999             /* The hashes have the same number of keys, so it suffices
4000                to check that one is a subset of the other. */
4001             (void) hv_iterinit((HV *) This);
4002             while ( (he = hv_iternext((HV *) This)) ) {
4003                 I32 key_len;
4004                 char * const key = hv_iterkey(he, &key_len);
4005
4006                 ++ this_key_count;
4007
4008                 if(!hv_exists(other_hv, key, key_len)) {
4009                     (void) hv_iterinit((HV *) This);    /* reset iterator */
4010                     RETPUSHNO;
4011                 }
4012             }
4013
4014             if (other_tied) {
4015                 (void) hv_iterinit(other_hv);
4016                 while ( hv_iternext(other_hv) )
4017                     ++other_key_count;
4018             }
4019             else
4020                 other_key_count = HvUSEDKEYS(other_hv);
4021
4022             if (this_key_count != other_key_count)
4023                 RETPUSHNO;
4024             else
4025                 RETPUSHYES;
4026         }
4027         else if (SM_OTHER_REF(PVAV)) {
4028             AV * const other_av = (AV *) SvRV(Other);
4029             const I32 other_len = av_len(other_av) + 1;
4030             I32 i;
4031
4032             for (i = 0; i < other_len; ++i) {
4033                 SV ** const svp = av_fetch(other_av, i, FALSE);
4034                 char *key;
4035                 STRLEN key_len;
4036
4037                 if (svp) {      /* ??? When can this not happen? */
4038                     key = SvPV(*svp, key_len);
4039                     if (hv_exists((HV *) This, key, key_len))
4040                         RETPUSHYES;
4041                 }
4042             }
4043             RETPUSHNO;
4044         }
4045         else if (SM_OTHER_REGEX) {
4046             PMOP * const matcher = make_matcher(other_regex);
4047             HE *he;
4048
4049             (void) hv_iterinit((HV *) This);
4050             while ( (he = hv_iternext((HV *) This)) ) {
4051                 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4052                     (void) hv_iterinit((HV *) This);
4053                     destroy_matcher(matcher);
4054                     RETPUSHYES;
4055                 }
4056             }
4057             destroy_matcher(matcher);
4058             RETPUSHNO;
4059         }
4060         else {
4061             if (hv_exists_ent((HV *) This, Other, 0))
4062                 RETPUSHYES;
4063             else
4064                 RETPUSHNO;
4065         }
4066     }
4067     else if (SM_REF(PVAV)) {
4068         if (SM_OTHER_REF(PVAV)) {
4069             AV *other_av = (AV *) SvRV(Other);
4070             if (av_len((AV *) This) != av_len(other_av))
4071                 RETPUSHNO;
4072             else {
4073                 I32 i;
4074                 const I32 other_len = av_len(other_av);
4075
4076                 if (NULL == seen_this) {
4077                     seen_this = newHV();
4078                     (void) sv_2mortal((SV *) seen_this);
4079                 }
4080                 if (NULL == seen_other) {
4081                     seen_this = newHV();
4082                     (void) sv_2mortal((SV *) seen_other);
4083                 }
4084                 for(i = 0; i <= other_len; ++i) {
4085                     SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4086                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4087
4088                     if (!this_elem || !other_elem) {
4089                         if (this_elem || other_elem)
4090                             RETPUSHNO;
4091                     }
4092                     else if (SM_SEEN_THIS(*this_elem)
4093                          || SM_SEEN_OTHER(*other_elem))
4094                     {
4095                         if (*this_elem != *other_elem)
4096                             RETPUSHNO;
4097                     }
4098                     else {
4099                         (void)hv_store_ent(seen_this,
4100                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4101                                 &PL_sv_undef, 0);
4102                         (void)hv_store_ent(seen_other,
4103                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4104                                 &PL_sv_undef, 0);
4105                         PUSHs(*this_elem);
4106                         PUSHs(*other_elem);
4107
4108                         PUTBACK;
4109                         (void) do_smartmatch(seen_this, seen_other);
4110                         SPAGAIN;
4111
4112                         if (!SvTRUEx(POPs))
4113                             RETPUSHNO;
4114                     }
4115                 }
4116                 RETPUSHYES;
4117             }
4118         }
4119         else if (SM_OTHER_REGEX) {
4120             PMOP * const matcher = make_matcher(other_regex);
4121             const I32 this_len = av_len((AV *) This);
4122             I32 i;
4123
4124             for(i = 0; i <= this_len; ++i) {
4125                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4126                 if (svp && matcher_matches_sv(matcher, *svp)) {
4127                     destroy_matcher(matcher);
4128                     RETPUSHYES;
4129                 }
4130             }
4131             destroy_matcher(matcher);
4132             RETPUSHNO;
4133         }
4134         else if (SvIOK(Other) || SvNOK(Other)) {
4135             I32 i;
4136
4137             for(i = 0; i <= AvFILL((AV *) This); ++i) {
4138                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4139                 if (!svp)
4140                     continue;
4141
4142                 PUSHs(Other);
4143                 PUSHs(*svp);
4144                 PUTBACK;
4145                 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4146                     (void) pp_i_eq();
4147                 else
4148                     (void) pp_eq();
4149                 SPAGAIN;
4150                 if (SvTRUEx(POPs))
4151                     RETPUSHYES;
4152             }
4153             RETPUSHNO;
4154         }
4155         else if (SvPOK(Other)) {
4156             const I32 this_len = av_len((AV *) This);
4157             I32 i;
4158
4159             for(i = 0; i <= this_len; ++i) {
4160                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4161                 if (!svp)
4162                     continue;
4163
4164                 PUSHs(Other);
4165                 PUSHs(*svp);
4166                 PUTBACK;
4167                 (void) pp_seq();
4168                 SPAGAIN;
4169                 if (SvTRUEx(POPs))
4170                     RETPUSHYES;
4171             }
4172             RETPUSHNO;
4173         }
4174     }
4175     else if (!SvOK(d) || !SvOK(e)) {
4176         if (!SvOK(d) && !SvOK(e))
4177             RETPUSHYES;
4178         else
4179             RETPUSHNO;
4180     }
4181     else if (SM_REGEX) {
4182         PMOP * const matcher = make_matcher(this_regex);
4183
4184         PUTBACK;
4185         PUSHs(matcher_matches_sv(matcher, Other)
4186             ? &PL_sv_yes
4187             : &PL_sv_no);
4188         destroy_matcher(matcher);
4189         RETURN;
4190     }
4191     else if (SM_REF(PVCV)) {
4192         I32 c;
4193         /* This must be a null-prototyped sub, because we
4194            already checked for the other kind. */
4195
4196         ENTER;
4197         SAVETMPS;
4198         PUSHMARK(SP);
4199         PUTBACK;
4200         c = call_sv(This, G_SCALAR);
4201         SPAGAIN;
4202         if (c == 0)
4203             PUSHs(&PL_sv_undef);
4204         else if (SvTEMP(TOPs))
4205             SvREFCNT_inc_void(TOPs);
4206
4207         if (SM_OTHER_REF(PVCV)) {
4208             /* This one has to be null-proto'd too.
4209                Call both of 'em, and compare the results */
4210             PUSHMARK(SP);
4211             c = call_sv(SvRV(Other), G_SCALAR);
4212             SPAGAIN;
4213             if (c == 0)
4214                 PUSHs(&PL_sv_undef);
4215             else if (SvTEMP(TOPs))
4216                 SvREFCNT_inc_void(TOPs);
4217             FREETMPS;
4218             LEAVE;
4219             PUTBACK;
4220             return pp_eq();
4221         }
4222
4223         FREETMPS;
4224         LEAVE;
4225         RETURN;
4226     }
4227     else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4228          ||   ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4229     {
4230         if (SvPOK(Other) && !looks_like_number(Other)) {
4231             /* String comparison */
4232             PUSHs(d); PUSHs(e);
4233             PUTBACK;
4234             return pp_seq();
4235         }
4236         /* Otherwise, numeric comparison */
4237         PUSHs(d); PUSHs(e);
4238         PUTBACK;
4239         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4240             (void) pp_i_eq();
4241         else
4242             (void) pp_eq();
4243         SPAGAIN;
4244         if (SvTRUEx(POPs))
4245             RETPUSHYES;
4246         else
4247             RETPUSHNO;
4248     }
4249
4250     /* As a last resort, use string comparison */
4251     PUSHs(d); PUSHs(e);
4252     PUTBACK;
4253     return pp_seq();
4254 }
4255
4256 PP(pp_enterwhen)
4257 {
4258     dVAR; dSP;
4259     register PERL_CONTEXT *cx;
4260     const I32 gimme = GIMME_V;
4261
4262     /* This is essentially an optimization: if the match
4263        fails, we don't want to push a context and then
4264        pop it again right away, so we skip straight
4265        to the op that follows the leavewhen.
4266     */
4267     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4268         return cLOGOP->op_other->op_next;
4269
4270     ENTER;
4271     SAVETMPS;
4272
4273     PUSHBLOCK(cx, CXt_WHEN, SP);
4274     PUSHWHEN(cx);
4275
4276     RETURN;
4277 }
4278
4279 PP(pp_leavewhen)
4280 {
4281     dVAR; dSP;
4282     register PERL_CONTEXT *cx;
4283     I32 gimme;
4284     SV **newsp;
4285     PMOP *newpm;
4286
4287     POPBLOCK(cx,newpm);
4288     assert(CxTYPE(cx) == CXt_WHEN);
4289
4290     SP = newsp;
4291     PUTBACK;
4292
4293     PL_curpm = newpm;   /* pop $1 et al */
4294
4295     LEAVE;
4296     return NORMAL;
4297 }
4298
4299 PP(pp_continue)
4300 {
4301     dVAR;
4302     I32 cxix;
4303     register PERL_CONTEXT *cx;
4304     I32 inner;
4305
4306     cxix = dopoptowhen(cxstack_ix);
4307     if (cxix < 0)
4308         DIE(aTHX_ "Can't \"continue\" outside a when block");
4309     if (cxix < cxstack_ix)
4310         dounwind(cxix);
4311
4312     /* clear off anything above the scope we're re-entering */
4313     inner = PL_scopestack_ix;
4314     TOPBLOCK(cx);
4315     if (PL_scopestack_ix < inner)
4316         leave_scope(PL_scopestack[PL_scopestack_ix]);
4317     PL_curcop = cx->blk_oldcop;
4318     return cx->blk_givwhen.leave_op;
4319 }
4320
4321 PP(pp_break)
4322 {
4323     dVAR;
4324     I32 cxix;
4325     register PERL_CONTEXT *cx;
4326     I32 inner;
4327
4328     cxix = dopoptogiven(cxstack_ix);
4329     if (cxix < 0) {
4330         if (PL_op->op_flags & OPf_SPECIAL)
4331             DIE(aTHX_ "Can't use when() outside a topicalizer");
4332         else
4333             DIE(aTHX_ "Can't \"break\" outside a given block");
4334     }
4335     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4336         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4337
4338     if (cxix < cxstack_ix)
4339         dounwind(cxix);
4340
4341     /* clear off anything above the scope we're re-entering */
4342     inner = PL_scopestack_ix;
4343     TOPBLOCK(cx);
4344     if (PL_scopestack_ix < inner)
4345         leave_scope(PL_scopestack[PL_scopestack_ix]);
4346     PL_curcop = cx->blk_oldcop;
4347
4348     if (CxFOREACH(cx))
4349         return CX_LOOP_NEXTOP_GET(cx);
4350     else
4351         return cx->blk_givwhen.leave_op;
4352 }
4353
4354 STATIC OP *
4355 S_doparseform(pTHX_ SV *sv)
4356 {
4357     STRLEN len;
4358     register char *s = SvPV_force(sv, len);
4359     register char * const send = s + len;
4360     register char *base = NULL;
4361     register I32 skipspaces = 0;
4362     bool noblank   = FALSE;
4363     bool repeat    = FALSE;
4364     bool postspace = FALSE;
4365     U32 *fops;
4366     register U32 *fpc;
4367     U32 *linepc = NULL;
4368     register I32 arg;
4369     bool ischop;
4370     bool unchopnum = FALSE;
4371     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4372
4373     if (len == 0)
4374         Perl_croak(aTHX_ "Null picture in formline");
4375
4376     /* estimate the buffer size needed */
4377     for (base = s; s <= send; s++) {
4378         if (*s == '\n' || *s == '@' || *s == '^')
4379             maxops += 10;
4380     }
4381     s = base;
4382     base = NULL;
4383
4384     Newx(fops, maxops, U32);
4385     fpc = fops;
4386
4387     if (s < send) {
4388         linepc = fpc;
4389         *fpc++ = FF_LINEMARK;
4390         noblank = repeat = FALSE;
4391         base = s;
4392     }
4393
4394     while (s <= send) {
4395         switch (*s++) {
4396         default:
4397             skipspaces = 0;
4398             continue;
4399
4400         case '~':
4401             if (*s == '~') {
4402                 repeat = TRUE;
4403                 *s = ' ';
4404             }
4405             noblank = TRUE;
4406             s[-1] = ' ';
4407             /* FALL THROUGH */
4408         case ' ': case '\t':
4409             skipspaces++;
4410             continue;
4411         case 0:
4412             if (s < send) {
4413                 skipspaces = 0;
4414                 continue;
4415             } /* else FALL THROUGH */
4416         case '\n':
4417             arg = s - base;
4418             skipspaces++;
4419             arg -= skipspaces;
4420             if (arg) {
4421                 if (postspace)
4422                     *fpc++ = FF_SPACE;
4423                 *fpc++ = FF_LITERAL;
4424                 *fpc++ = (U16)arg;
4425             }
4426             postspace = FALSE;
4427             if (s <= send)
4428                 skipspaces--;
4429             if (skipspaces) {
4430                 *fpc++ = FF_SKIP;
4431                 *fpc++ = (U16)skipspaces;
4432             }
4433             skipspaces = 0;
4434             if (s <= send)
4435                 *fpc++ = FF_NEWLINE;
4436             if (noblank) {
4437                 *fpc++ = FF_BLANK;
4438                 if (repeat)
4439                     arg = fpc - linepc + 1;
4440                 else
4441                     arg = 0;
4442                 *fpc++ = (U16)arg;
4443             }
4444             if (s < send) {
4445                 linepc = fpc;
4446                 *fpc++ = FF_LINEMARK;
4447                 noblank = repeat = FALSE;
4448                 base = s;
4449             }
4450             else
4451                 s++;
4452             continue;
4453
4454         case '@':
4455         case '^':
4456             ischop = s[-1] == '^';
4457
4458             if (postspace) {
4459                 *fpc++ = FF_SPACE;
4460                 postspace = FALSE;
4461             }
4462             arg = (s - base) - 1;
4463             if (arg) {
4464                 *fpc++ = FF_LITERAL;
4465                 *fpc++ = (U16)arg;
4466             }
4467
4468             base = s - 1;
4469             *fpc++ = FF_FETCH;
4470             if (*s == '*') {
4471                 s++;
4472                 *fpc++ = 2;  /* skip the @* or ^* */
4473                 if (ischop) {
4474                     *fpc++ = FF_LINESNGL;
4475                     *fpc++ = FF_CHOP;
4476                 } else
4477                     *fpc++ = FF_LINEGLOB;
4478             }
4479             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4480                 arg = ischop ? 512 : 0;
4481                 base = s - 1;
4482                 while (*s == '#')
4483                     s++;
4484                 if (*s == '.') {
4485                     const char * const f = ++s;
4486                     while (*s == '#')
4487                         s++;
4488                     arg |= 256 + (s - f);
4489                 }
4490                 *fpc++ = s - base;              /* fieldsize for FETCH */
4491                 *fpc++ = FF_DECIMAL;
4492                 *fpc++ = (U16)arg;
4493                 unchopnum |= ! ischop;
4494             }
4495             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4496                 arg = ischop ? 512 : 0;
4497                 base = s - 1;
4498                 s++;                                /* skip the '0' first */
4499                 while (*s == '#')
4500                     s++;
4501                 if (*s == '.') {
4502                     const char * const f = ++s;
4503                     while (*s == '#')
4504                         s++;
4505                     arg |= 256 + (s - f);
4506                 }
4507                 *fpc++ = s - base;                /* fieldsize for FETCH */
4508                 *fpc++ = FF_0DECIMAL;
4509                 *fpc++ = (U16)arg;
4510                 unchopnum |= ! ischop;
4511             }
4512             else {
4513                 I32 prespace = 0;
4514                 bool ismore = FALSE;
4515
4516                 if (*s == '>') {
4517                     while (*++s == '>') ;
4518                     prespace = FF_SPACE;
4519                 }
4520                 else if (*s == '|') {
4521                     while (*++s == '|') ;
4522                     prespace = FF_HALFSPACE;
4523                     postspace = TRUE;
4524                 }
4525                 else {
4526                     if (*s == '<')
4527                         while (*++s == '<') ;
4528                     postspace = TRUE;
4529                 }
4530                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4531                     s += 3;
4532                     ismore = TRUE;
4533                 }
4534                 *fpc++ = s - base;              /* fieldsize for FETCH */
4535
4536                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4537
4538                 if (prespace)
4539                     *fpc++ = (U16)prespace;
4540                 *fpc++ = FF_ITEM;
4541                 if (ismore)
4542                     *fpc++ = FF_MORE;
4543                 if (ischop)
4544                     *fpc++ = FF_CHOP;
4545             }
4546             base = s;
4547             skipspaces = 0;
4548             continue;
4549         }
4550     }
4551     *fpc++ = FF_END;
4552
4553     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4554     arg = fpc - fops;
4555     { /* need to jump to the next word */
4556         int z;
4557         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4558         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4559         s = SvPVX(sv) + SvCUR(sv) + z;
4560     }
4561     Copy(fops, s, arg, U32);
4562     Safefree(fops);
4563     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4564     SvCOMPILED_on(sv);
4565
4566     if (unchopnum && repeat)
4567         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4568     return 0;
4569 }
4570
4571
4572 STATIC bool
4573 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4574 {
4575     /* Can value be printed in fldsize chars, using %*.*f ? */
4576     NV pwr = 1;
4577     NV eps = 0.5;
4578     bool res = FALSE;
4579     int intsize = fldsize - (value < 0 ? 1 : 0);
4580
4581     if (frcsize & 256)
4582         intsize--;
4583     frcsize &= 255;
4584     intsize -= frcsize;
4585
4586     while (intsize--) pwr *= 10.0;
4587     while (frcsize--) eps /= 10.0;
4588
4589     if( value >= 0 ){
4590         if (value + eps >= pwr)
4591             res = TRUE;
4592     } else {
4593         if (value - eps <= -pwr)
4594             res = TRUE;
4595     }
4596     return res;
4597 }
4598
4599 static I32
4600 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4601 {
4602     dVAR;
4603     SV * const datasv = FILTER_DATA(idx);
4604     const int filter_has_file = IoLINES(datasv);
4605     SV * const filter_state = (SV *)IoTOP_GV(datasv);
4606     SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4607     int status = 0;
4608     SV *upstream;
4609     STRLEN got_len;
4610     const char *got_p = NULL;
4611     const char *prune_from = NULL;
4612     bool read_from_cache = FALSE;
4613     STRLEN umaxlen;
4614
4615     assert(maxlen >= 0);
4616     umaxlen = maxlen;
4617
4618     /* I was having segfault trouble under Linux 2.2.5 after a
4619        parse error occured.  (Had to hack around it with a test
4620        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4621        not sure where the trouble is yet.  XXX */
4622
4623     if (IoFMT_GV(datasv)) {
4624         SV *const cache = (SV *)IoFMT_GV(datasv);
4625         if (SvOK(cache)) {
4626             STRLEN cache_len;
4627             const char *cache_p = SvPV(cache, cache_len);
4628             STRLEN take = 0;
4629
4630             if (umaxlen) {
4631                 /* Running in block mode and we have some cached data already.
4632                  */
4633                 if (cache_len >= umaxlen) {
4634                     /* In fact, so much data we don't even need to call
4635                        filter_read.  */
4636                     take = umaxlen;
4637                 }
4638             } else {
4639                 const char *const first_nl =
4640                     (const char *)memchr(cache_p, '\n', cache_len);
4641                 if (first_nl) {
4642                     take = first_nl + 1 - cache_p;
4643                 }
4644             }
4645             if (take) {
4646                 sv_catpvn(buf_sv, cache_p, take);
4647                 sv_chop(cache, cache_p + take);
4648                 /* Definately not EOF  */
4649                 return 1;
4650             }
4651
4652             sv_catsv(buf_sv, cache);
4653             if (umaxlen) {
4654                 umaxlen -= cache_len;
4655             }
4656             SvOK_off(cache);
4657             read_from_cache = TRUE;
4658         }
4659     }
4660
4661     /* Filter API says that the filter appends to the contents of the buffer.
4662        Usually the buffer is "", so the details don't matter. But if it's not,
4663        then clearly what it contains is already filtered by this filter, so we
4664        don't want to pass it in a second time.
4665        I'm going to use a mortal in case the upstream filter croaks.  */
4666     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4667         ? sv_newmortal() : buf_sv;
4668     SvUPGRADE(upstream, SVt_PV);
4669
4670     if (filter_has_file) {
4671         status = FILTER_READ(idx+1, upstream, 0);
4672     }
4673
4674     if (filter_sub && status >= 0) {
4675         dSP;
4676         int count;
4677
4678         ENTER;
4679         SAVE_DEFSV;
4680         SAVETMPS;
4681         EXTEND(SP, 2);
4682
4683         DEFSV = upstream;
4684         PUSHMARK(SP);
4685         PUSHs(sv_2mortal(newSViv(0)));
4686         if (filter_state) {
4687             PUSHs(filter_state);
4688         }
4689         PUTBACK;
4690         count = call_sv(filter_sub, G_SCALAR);
4691         SPAGAIN;
4692
4693         if (count > 0) {
4694             SV *out = POPs;
4695             if (SvOK(out)) {
4696                 status = SvIV(out);
4697             }
4698         }
4699
4700         PUTBACK;
4701         FREETMPS;
4702         LEAVE;
4703     }
4704
4705     if(SvOK(upstream)) {
4706         got_p = SvPV(upstream, got_len);
4707         if (umaxlen) {
4708             if (got_len > umaxlen) {
4709                 prune_from = got_p + umaxlen;
4710             }
4711         } else {
4712             const char *const first_nl =
4713                 (const char *)memchr(got_p, '\n', got_len);
4714             if (first_nl && first_nl + 1 < got_p + got_len) {
4715                 /* There's a second line here... */
4716                 prune_from = first_nl + 1;
4717             }
4718         }
4719     }
4720     if (prune_from) {
4721         /* Oh. Too long. Stuff some in our cache.  */
4722         STRLEN cached_len = got_p + got_len - prune_from;
4723         SV *cache = (SV *)IoFMT_GV(datasv);
4724
4725         if (!cache) {
4726             IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4727         } else if (SvOK(cache)) {
4728             /* Cache should be empty.  */
4729             assert(!SvCUR(cache));
4730         }
4731
4732         sv_setpvn(cache, prune_from, cached_len);
4733         /* If you ask for block mode, you may well split UTF-8 characters.
4734            "If it breaks, you get to keep both parts"
4735            (Your code is broken if you  don't put them back together again
4736            before something notices.) */
4737         if (SvUTF8(upstream)) {
4738             SvUTF8_on(cache);
4739         }
4740         SvCUR_set(upstream, got_len - cached_len);
4741         /* Can't yet be EOF  */
4742         if (status == 0)
4743             status = 1;
4744     }
4745
4746     /* If they are at EOF but buf_sv has something in it, then they may never
4747        have touched the SV upstream, so it may be undefined.  If we naively
4748        concatenate it then we get a warning about use of uninitialised value.
4749     */
4750     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4751         sv_catsv(buf_sv, upstream);
4752     }
4753
4754     if (status <= 0) {
4755         IoLINES(datasv) = 0;
4756         SvREFCNT_dec(IoFMT_GV(datasv));
4757         if (filter_state) {
4758             SvREFCNT_dec(filter_state);
4759             IoTOP_GV(datasv) = NULL;
4760         }
4761         if (filter_sub) {
4762             SvREFCNT_dec(filter_sub);
4763             IoBOTTOM_GV(datasv) = NULL;
4764         }
4765         filter_del(S_run_user_filter);
4766     }
4767     if (status == 0 && read_from_cache) {
4768         /* If we read some data from the cache (and by getting here it implies
4769            that we emptied the cache) then we aren't yet at EOF, and mustn't
4770            report that to our caller.  */
4771         return 1;
4772     }
4773     return status;
4774 }
4775
4776 /* perhaps someone can come up with a better name for
4777    this?  it is not really "absolute", per se ... */
4778 static bool
4779 S_path_is_absolute(const char *name)
4780 {
4781     if (PERL_FILE_IS_ABSOLUTE(name)
4782 #ifdef MACOS_TRADITIONAL
4783         || (*name == ':')
4784 #else
4785         || (*name == '.' && (name[1] == '/' ||
4786                              (name[1] == '.' && name[2] == '/')))
4787 #endif
4788          )
4789     {
4790         return TRUE;
4791     }
4792     else
4793         return FALSE;
4794 }
4795
4796 /*
4797  * Local variables:
4798  * c-indentation-style: bsd
4799  * c-basic-offset: 4
4800  * indent-tabs-mode: t
4801  * End:
4802  *
4803  * ex: set ts=8 sts=4 sw=4 noet:
4804  */