pp_hot.c

   1 /*    pp_hot.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  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  13  * shaking the air.
  14  *
  15  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
  16  *                     Fire, Foes!  Awake!
  17  */
  18
  19 /* This file contains 'hot' pp ("push/pop") functions that
  20  * execute the opcodes that make up a perl program. A typical pp function
  21  * expects to find its arguments on the stack, and usually pushes its
  22  * results onto the stack, hence the 'pp' terminology. Each OP structure
  23  * contains a pointer to the relevant pp_foo() function.
  24  *
  25  * By 'hot', we mean common ops whose execution speed is critical.
  26  * By gathering them together into a single file, we encourage
  27  * CPU cache hits on hot code. Also it could be taken as a warning not to
  28  * change any code in this file unless you're sure it won't affect
  29  * performance.
  30  */
  31
  32 #include "EXTERN.h"
  33 #define PERL_IN_PP_HOT_C
  34 #include "perl.h"
  35
  36 /* Hot code. */
  37
  38 PP(pp_const)
  39 {
  40     dVAR;
  41     dSP;
  42     if ( PL_op->op_flags & OPf_SPECIAL )
  43         /* This is a const op added to hold the hints hash for
  44            pp_entereval. The hash can be modified by the code
  45            being eval'ed, so we return a copy instead. */
  46         XPUSHs(sv_2mortal((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv)));
  47     else
  48         /* Normal const. */
  49         XPUSHs(cSVOP_sv);
  50     RETURN;
  51 }
  52
  53 PP(pp_nextstate)
  54 {
  55     dVAR;
  56     PL_curcop = (COP*)PL_op;
  57     TAINT_NOT;          /* Each statement is presumed innocent */
  58     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
  59     FREETMPS;
  60     return NORMAL;
  61 }
  62
  63 PP(pp_gvsv)
  64 {
  65     dVAR;
  66     dSP;
  67     EXTEND(SP,1);
  68     if (PL_op->op_private & OPpLVAL_INTRO)
  69         PUSHs(save_scalar(cGVOP_gv));
  70     else
  71         PUSHs(GvSVn(cGVOP_gv));
  72     RETURN;
  73 }
  74
  75 PP(pp_null)
  76 {
  77     dVAR;
  78     return NORMAL;
  79 }
  80
  81 PP(pp_setstate)
  82 {
  83     dVAR;
  84     PL_curcop = (COP*)PL_op;
  85     return NORMAL;
  86 }
  87
  88 PP(pp_pushmark)
  89 {
  90     dVAR;
  91     PUSHMARK(PL_stack_sp);
  92     return NORMAL;
  93 }
  94
  95 PP(pp_stringify)
  96 {
  97     dVAR; dSP; dTARGET;
  98     sv_copypv(TARG,TOPs);
  99     SETTARG;
 100     RETURN;
 101 }
 102
 103 PP(pp_gv)
 104 {
 105     dVAR; dSP;
 106     XPUSHs((SV*)cGVOP_gv);
 107     RETURN;
 108 }
 109
 110 PP(pp_and)
 111 {
 112     dVAR; dSP;
 113     if (!SvTRUE(TOPs))
 114         RETURN;
 115     else {
 116         if (PL_op->op_type == OP_AND)
 117             --SP;
 118         RETURNOP(cLOGOP->op_other);
 119     }
 120 }
 121
 122 PP(pp_sassign)
 123 {
 124     dVAR; dSP; dPOPTOPssrl;
 125
 126     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
 127         SV * const temp = left;
 128         left = right; right = temp;
 129     }
 130     else if (PL_op->op_private & OPpASSIGN_STATE) {
 131         if (SvPADSTALE(right))
 132             SvPADSTALE_off(right);
 133         else {
 134             (void)POPs;
 135             PUSHs(right);
 136             RETURN; /* ignore assignment */
 137         }
 138     }
 139     if (PL_tainting && PL_tainted && !SvTAINTED(left))
 140         TAINT_NOT;
 141     if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
 142         SV * const cv = SvRV(left);
 143         const U32 cv_type = SvTYPE(cv);
 144         const U32 gv_type = SvTYPE(right);
 145         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
 146
 147         if (!got_coderef) {
 148             assert(SvROK(cv));
 149         }
 150
 151         /* Can do the optimisation if right (LVALUE) is not a typeglob,
 152            left (RVALUE) is a reference to something, and we're in void
 153            context. */
 154         if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
 155             /* Is the target symbol table currently empty?  */
 156             GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
 157             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
 158                 /* Good. Create a new proxy constant subroutine in the target.
 159                    The gv becomes a(nother) reference to the constant.  */
 160                 SV *const value = SvRV(cv);
 161
 162                 SvUPGRADE((SV *)gv, SVt_RV);
 163                 SvPCS_IMPORTED_on(gv);
 164                 SvRV_set(gv, value);
 165                 SvREFCNT_inc_simple_void(value);
 166                 SETs(right);
 167                 RETURN;
 168             }
 169         }
 170
 171         /* Need to fix things up.  */
 172         if (gv_type != SVt_PVGV) {
 173             /* Need to fix GV.  */
 174             right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
 175         }
 176
 177         if (!got_coderef) {
 178             /* We've been returned a constant rather than a full subroutine,
 179                but they expect a subroutine reference to apply.  */
 180             ENTER;
 181             SvREFCNT_inc_void(SvRV(cv));
 182             /* newCONSTSUB takes a reference count on the passed in SV
 183                from us.  We set the name to NULL, otherwise we get into
 184                all sorts of fun as the reference to our new sub is
 185                donated to the GV that we're about to assign to.
 186             */
 187             SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
 188                                                  SvRV(cv)));
 189             SvREFCNT_dec(cv);
 190             LEAVE;
 191         }
 192
 193         if (strEQ(GvNAME(right),"isa")) {
 194             GvCVGEN(right) = 0;
 195             ++PL_sub_generation;
 196         }
 197     }
 198     SvSetMagicSV(right, left);
 199     SETs(right);
 200     RETURN;
 201 }
 202
 203 PP(pp_cond_expr)
 204 {
 205     dVAR; dSP;
 206     if (SvTRUEx(POPs))
 207         RETURNOP(cLOGOP->op_other);
 208     else
 209         RETURNOP(cLOGOP->op_next);
 210 }
 211
 212 PP(pp_unstack)
 213 {
 214     dVAR;
 215     I32 oldsave;
 216     TAINT_NOT;          /* Each statement is presumed innocent */
 217     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 218     FREETMPS;
 219     oldsave = PL_scopestack[PL_scopestack_ix - 1];
 220     LEAVE_SCOPE(oldsave);
 221     return NORMAL;
 222 }
 223
 224 PP(pp_concat)
 225 {
 226   dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
 227   {
 228     dPOPTOPssrl;
 229     bool lbyte;
 230     STRLEN rlen;
 231     const char *rpv = NULL;
 232     bool rbyte = FALSE;
 233     bool rcopied = FALSE;
 234
 235     if (TARG == right && right != left) {
 236         /* mg_get(right) may happen here ... */
 237         rpv = SvPV_const(right, rlen);
 238         rbyte = !DO_UTF8(right);
 239         right = sv_2mortal(newSVpvn(rpv, rlen));
 240         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
 241         rcopied = TRUE;
 242     }
 243
 244     if (TARG != left) {
 245         STRLEN llen;
 246         const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
 247         lbyte = !DO_UTF8(left);
 248         sv_setpvn(TARG, lpv, llen);
 249         if (!lbyte)
 250             SvUTF8_on(TARG);
 251         else
 252             SvUTF8_off(TARG);
 253     }
 254     else { /* TARG == left */
 255         STRLEN llen;
 256         SvGETMAGIC(left);               /* or mg_get(left) may happen here */
 257         if (!SvOK(TARG)) {
 258             if (left == right && ckWARN(WARN_UNINITIALIZED))
 259                 report_uninit(right);
 260             sv_setpvn(left, "", 0);
 261         }
 262         (void)SvPV_nomg_const(left, llen);    /* Needed to set UTF8 flag */
 263         lbyte = !DO_UTF8(left);
 264         if (IN_BYTES)
 265             SvUTF8_off(TARG);
 266     }
 267
 268     /* or mg_get(right) may happen here */
 269     if (!rcopied) {
 270         rpv = SvPV_const(right, rlen);
 271         rbyte = !DO_UTF8(right);
 272     }
 273     if (lbyte != rbyte) {
 274         if (lbyte)
 275             sv_utf8_upgrade_nomg(TARG);
 276         else {
 277             if (!rcopied)
 278                 right = sv_2mortal(newSVpvn(rpv, rlen));
 279             sv_utf8_upgrade_nomg(right);
 280             rpv = SvPV_const(right, rlen);
 281         }
 282     }
 283     sv_catpvn_nomg(TARG, rpv, rlen);
 284
 285     SETTARG;
 286     RETURN;
 287   }
 288 }
 289
 290 PP(pp_padsv)
 291 {
 292     dVAR; dSP; dTARGET;
 293     XPUSHs(TARG);
 294     if (PL_op->op_flags & OPf_MOD) {
 295         if (PL_op->op_private & OPpLVAL_INTRO)
 296             if (!(PL_op->op_private & OPpPAD_STATE))
 297                 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 298         if (PL_op->op_private & OPpDEREF) {
 299             PUTBACK;
 300             vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
 301             SPAGAIN;
 302         }
 303     }
 304     RETURN;
 305 }
 306
 307 PP(pp_readline)
 308 {
 309     dVAR;
 310     tryAMAGICunTARGET(iter, 0);
 311     PL_last_in_gv = (GV*)(*PL_stack_sp--);
 312     if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
 313         if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
 314             PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
 315         else {
 316             dSP;
 317             XPUSHs((SV*)PL_last_in_gv);
 318             PUTBACK;
 319             pp_rv2gv();
 320             PL_last_in_gv = (GV*)(*PL_stack_sp--);
 321         }
 322     }
 323     return do_readline();
 324 }
 325
 326 PP(pp_eq)
 327 {
 328     dVAR; dSP; tryAMAGICbinSET(eq,0);
 329 #ifndef NV_PRESERVES_UV
 330     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
 331         SP--;
 332         SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
 333         RETURN;
 334     }
 335 #endif
 336 #ifdef PERL_PRESERVE_IVUV
 337     SvIV_please(TOPs);
 338     if (SvIOK(TOPs)) {
 339         /* Unless the left argument is integer in range we are going
 340            to have to use NV maths. Hence only attempt to coerce the
 341            right argument if we know the left is integer.  */
 342       SvIV_please(TOPm1s);
 343         if (SvIOK(TOPm1s)) {
 344             const bool auvok = SvUOK(TOPm1s);
 345             const bool buvok = SvUOK(TOPs);
 346
 347             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
 348                 /* Casting IV to UV before comparison isn't going to matter
 349                    on 2s complement. On 1s complement or sign&magnitude
 350                    (if we have any of them) it could to make negative zero
 351                    differ from normal zero. As I understand it. (Need to
 352                    check - is negative zero implementation defined behaviour
 353                    anyway?). NWC  */
 354                 const UV buv = SvUVX(POPs);
 355                 const UV auv = SvUVX(TOPs);
 356
 357                 SETs(boolSV(auv == buv));
 358                 RETURN;
 359             }
 360             {                   /* ## Mixed IV,UV ## */
 361                 SV *ivp, *uvp;
 362                 IV iv;
 363
 364                 /* == is commutative so doesn't matter which is left or right */
 365                 if (auvok) {
 366                     /* top of stack (b) is the iv */
 367                     ivp = *SP;
 368                     uvp = *--SP;
 369                 } else {
 370                     uvp = *SP;
 371                     ivp = *--SP;
 372                 }
 373                 iv = SvIVX(ivp);
 374                 if (iv < 0)
 375                     /* As uv is a UV, it's >0, so it cannot be == */
 376                     SETs(&PL_sv_no);
 377                 else
 378                     /* we know iv is >= 0 */
 379                     SETs(boolSV((UV)iv == SvUVX(uvp)));
 380                 RETURN;
 381             }
 382         }
 383     }
 384 #endif
 385     {
 386 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
 387       dPOPTOPnnrl;
 388       if (Perl_isnan(left) || Perl_isnan(right))
 389           RETSETNO;
 390       SETs(boolSV(left == right));
 391 #else
 392       dPOPnv;
 393       SETs(boolSV(TOPn == value));
 394 #endif
 395       RETURN;
 396     }
 397 }
 398
 399 PP(pp_preinc)
 400 {
 401     dVAR; dSP;
 402     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 403         DIE(aTHX_ PL_no_modify);
 404     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 405         && SvIVX(TOPs) != IV_MAX)
 406     {
 407         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 408         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 409     }
 410     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
 411         sv_inc(TOPs);
 412     SvSETMAGIC(TOPs);
 413     return NORMAL;
 414 }
 415
 416 PP(pp_or)
 417 {
 418     dVAR; dSP;
 419     if (SvTRUE(TOPs))
 420         RETURN;
 421     else {
 422         if (PL_op->op_type == OP_OR)
 423             --SP;
 424         RETURNOP(cLOGOP->op_other);
 425     }
 426 }
 427
 428 PP(pp_defined)
 429 {
 430     dVAR; dSP;
 431     register SV* sv;
 432     bool defined;
 433     const int op_type = PL_op->op_type;
 434     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
 435
 436     if (is_dor) {
 437         sv = TOPs;
 438         if (!sv || !SvANY(sv)) {
 439             if (op_type == OP_DOR)
 440                 --SP;
 441             RETURNOP(cLOGOP->op_other);
 442         }
 443     } else if (op_type == OP_DEFINED) {
 444         sv = POPs;
 445         if (!sv || !SvANY(sv))
 446             RETPUSHNO;
 447     } else
 448         DIE(aTHX_ "panic:  Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
 449
 450     defined = FALSE;
 451     switch (SvTYPE(sv)) {
 452     case SVt_PVAV:
 453         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 454             defined = TRUE;
 455         break;
 456     case SVt_PVHV:
 457         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 458             defined = TRUE;
 459         break;
 460     case SVt_PVCV:
 461         if (CvROOT(sv) || CvXSUB(sv))
 462             defined = TRUE;
 463         break;
 464     default:
 465         SvGETMAGIC(sv);
 466         if (SvOK(sv))
 467             defined = TRUE;
 468         break;
 469     }
 470
 471     if (is_dor) {
 472         if(defined)
 473             RETURN;
 474         if(op_type == OP_DOR)
 475             --SP;
 476         RETURNOP(cLOGOP->op_other);
 477     }
 478     /* assuming OP_DEFINED */
 479     if(defined)
 480         RETPUSHYES;
 481     RETPUSHNO;
 482 }
 483
 484 PP(pp_add)
 485 {
 486     dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
 487     useleft = USE_LEFT(TOPm1s);
 488 #ifdef PERL_PRESERVE_IVUV
 489     /* We must see if we can perform the addition with integers if possible,
 490        as the integer code detects overflow while the NV code doesn't.
 491        If either argument hasn't had a numeric conversion yet attempt to get
 492        the IV. It's important to do this now, rather than just assuming that
 493        it's not IOK as a PV of "9223372036854775806" may not take well to NV
 494        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
 495        integer in case the second argument is IV=9223372036854775806
 496        We can (now) rely on sv_2iv to do the right thing, only setting the
 497        public IOK flag if the value in the NV (or PV) slot is truly integer.
 498
 499        A side effect is that this also aggressively prefers integer maths over
 500        fp maths for integer values.
 501
 502        How to detect overflow?
 503
 504        C 99 section 6.2.6.1 says
 505
 506        The range of nonnegative values of a signed integer type is a subrange
 507        of the corresponding unsigned integer type, and the representation of
 508        the same value in each type is the same. A computation involving
 509        unsigned operands can never overflow, because a result that cannot be
 510        represented by the resulting unsigned integer type is reduced modulo
 511        the number that is one greater than the largest value that can be
 512        represented by the resulting type.
 513
 514        (the 9th paragraph)
 515
 516        which I read as "unsigned ints wrap."
 517
 518        signed integer overflow seems to be classed as "exception condition"
 519
 520        If an exceptional condition occurs during the evaluation of an
 521        expression (that is, if the result is not mathematically defined or not
 522        in the range of representable values for its type), the behavior is
 523        undefined.
 524
 525        (6.5, the 5th paragraph)
 526
 527        I had assumed that on 2s complement machines signed arithmetic would
 528        wrap, hence coded pp_add and pp_subtract on the assumption that
 529        everything perl builds on would be happy.  After much wailing and
 530        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
 531        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
 532        unsigned code below is actually shorter than the old code. :-)
 533     */
 534
 535     SvIV_please(TOPs);
 536     if (SvIOK(TOPs)) {
 537         /* Unless the left argument is integer in range we are going to have to
 538            use NV maths. Hence only attempt to coerce the right argument if
 539            we know the left is integer.  */
 540         register UV auv = 0;
 541         bool auvok = FALSE;
 542         bool a_valid = 0;
 543
 544         if (!useleft) {
 545             auv = 0;
 546             a_valid = auvok = 1;
 547             /* left operand is undef, treat as zero. + 0 is identity,
 548                Could SETi or SETu right now, but space optimise by not adding
 549                lots of code to speed up what is probably a rarish case.  */
 550         } else {
 551             /* Left operand is defined, so is it IV? */
 552             SvIV_please(TOPm1s);
 553             if (SvIOK(TOPm1s)) {
 554                 if ((auvok = SvUOK(TOPm1s)))
 555                     auv = SvUVX(TOPm1s);
 556                 else {
 557                     register const IV aiv = SvIVX(TOPm1s);
 558                     if (aiv >= 0) {
 559                         auv = aiv;
 560                         auvok = 1;      /* Now acting as a sign flag.  */
 561                     } else { /* 2s complement assumption for IV_MIN */
 562                         auv = (UV)-aiv;
 563                     }
 564                 }
 565                 a_valid = 1;
 566             }
 567         }
 568         if (a_valid) {
 569             bool result_good = 0;
 570             UV result;
 571             register UV buv;
 572             bool buvok = SvUOK(TOPs);
 573
 574             if (buvok)
 575                 buv = SvUVX(TOPs);
 576             else {
 577                 register const IV biv = SvIVX(TOPs);
 578                 if (biv >= 0) {
 579                     buv = biv;
 580                     buvok = 1;
 581                 } else
 582                     buv = (UV)-biv;
 583             }
 584             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
 585                else "IV" now, independent of how it came in.
 586                if a, b represents positive, A, B negative, a maps to -A etc
 587                a + b =>  (a + b)
 588                A + b => -(a - b)
 589                a + B =>  (a - b)
 590                A + B => -(a + b)
 591                all UV maths. negate result if A negative.
 592                add if signs same, subtract if signs differ. */
 593
 594             if (auvok ^ buvok) {
 595                 /* Signs differ.  */
 596                 if (auv >= buv) {
 597                     result = auv - buv;
 598                     /* Must get smaller */
 599                     if (result <= auv)
 600                         result_good = 1;
 601                 } else {
 602                     result = buv - auv;
 603                     if (result <= buv) {
 604                         /* result really should be -(auv-buv). as its negation
 605                            of true value, need to swap our result flag  */
 606                         auvok = !auvok;
 607                         result_good = 1;
 608                     }
 609                 }
 610             } else {
 611                 /* Signs same */
 612                 result = auv + buv;
 613                 if (result >= auv)
 614                     result_good = 1;
 615             }
 616             if (result_good) {
 617                 SP--;
 618                 if (auvok)
 619                     SETu( result );
 620                 else {
 621                     /* Negate result */
 622                     if (result <= (UV)IV_MIN)
 623                         SETi( -(IV)result );
 624                     else {
 625                         /* result valid, but out of range for IV.  */
 626                         SETn( -(NV)result );
 627                     }
 628                 }
 629                 RETURN;
 630             } /* Overflow, drop through to NVs.  */
 631         }
 632     }
 633 #endif
 634     {
 635         dPOPnv;
 636         if (!useleft) {
 637             /* left operand is undef, treat as zero. + 0.0 is identity. */
 638             SETn(value);
 639             RETURN;
 640         }
 641         SETn( value + TOPn );
 642         RETURN;
 643     }
 644 }
 645
 646 PP(pp_aelemfast)
 647 {
 648     dVAR; dSP;
 649     AV * const av = PL_op->op_flags & OPf_SPECIAL ?
 650                 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
 651     const U32 lval = PL_op->op_flags & OPf_MOD;
 652     SV** const svp = av_fetch(av, PL_op->op_private, lval);
 653     SV *sv = (svp ? *svp : &PL_sv_undef);
 654     EXTEND(SP, 1);
 655     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
 656         sv = sv_mortalcopy(sv);
 657     PUSHs(sv);
 658     RETURN;
 659 }
 660
 661 PP(pp_join)
 662 {
 663     dVAR; dSP; dMARK; dTARGET;
 664     MARK++;
 665     do_join(TARG, *MARK, MARK, SP);
 666     SP = MARK;
 667     SETs(TARG);
 668     RETURN;
 669 }
 670
 671 PP(pp_pushre)
 672 {
 673     dVAR; dSP;
 674 #ifdef DEBUGGING
 675     /*
 676      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 677      * will be enough to hold an OP*.
 678      */
 679     SV* const sv = sv_newmortal();
 680     sv_upgrade(sv, SVt_PVLV);
 681     LvTYPE(sv) = '/';
 682     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
 683     XPUSHs(sv);
 684 #else
 685     XPUSHs((SV*)PL_op);
 686 #endif
 687     RETURN;
 688 }
 689
 690 /* Oversized hot code. */
 691
 692 PP(pp_print)
 693 {
 694     dVAR; dSP; dMARK; dORIGMARK;
 695     IO *io;
 696     register PerlIO *fp;
 697     MAGIC *mg;
 698     GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
 699
 700     if (gv && (io = GvIO(gv))
 701         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 702     {
 703       had_magic:
 704         if (MARK == ORIGMARK) {
 705             /* If using default handle then we need to make space to
 706              * pass object as 1st arg, so move other args up ...
 707              */
 708             MEXTEND(SP, 1);
 709             ++MARK;
 710             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 711             ++SP;
 712         }
 713         PUSHMARK(MARK - 1);
 714         *MARK = SvTIED_obj((SV*)io, mg);
 715         PUTBACK;
 716         ENTER;
 717         call_method("PRINT", G_SCALAR);
 718         LEAVE;
 719         SPAGAIN;
 720         MARK = ORIGMARK + 1;
 721         *MARK = *SP;
 722         SP = MARK;
 723         RETURN;
 724     }
 725     if (!(io = GvIO(gv))) {
 726         if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
 727             && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 728             goto had_magic;
 729         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 730             report_evil_fh(gv, io, PL_op->op_type);
 731         SETERRNO(EBADF,RMS_IFI);
 732         goto just_say_no;
 733     }
 734     else if (!(fp = IoOFP(io))) {
 735         if (ckWARN2(WARN_CLOSED, WARN_IO))  {
 736             if (IoIFP(io))
 737                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
 738             else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 739                 report_evil_fh(gv, io, PL_op->op_type);
 740         }
 741         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
 742         goto just_say_no;
 743     }
 744     else {
 745         MARK++;
 746         if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
 747             while (MARK <= SP) {
 748                 if (!do_print(*MARK, fp))
 749                     break;
 750                 MARK++;
 751                 if (MARK <= SP) {
 752                     if (!do_print(PL_ofs_sv, fp)) { /* $, */
 753                         MARK--;
 754                         break;
 755                     }
 756                 }
 757             }
 758         }
 759         else {
 760             while (MARK <= SP) {
 761                 if (!do_print(*MARK, fp))
 762                     break;
 763                 MARK++;
 764             }
 765         }
 766         if (MARK <= SP)
 767             goto just_say_no;
 768         else {
 769             if (PL_op->op_type == OP_SAY) {
 770                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
 771                     goto just_say_no;
 772             }
 773             else if (PL_ors_sv && SvOK(PL_ors_sv))
 774                 if (!do_print(PL_ors_sv, fp)) /* $\ */
 775                     goto just_say_no;
 776
 777             if (IoFLAGS(io) & IOf_FLUSH)
 778                 if (PerlIO_flush(fp) == EOF)
 779                     goto just_say_no;
 780         }
 781     }
 782     SP = ORIGMARK;
 783     XPUSHs(&PL_sv_yes);
 784     RETURN;
 785
 786   just_say_no:
 787     SP = ORIGMARK;
 788     XPUSHs(&PL_sv_undef);
 789     RETURN;
 790 }
 791
 792 PP(pp_rv2av)
 793 {
 794     dVAR; dSP; dTOPss;
 795     const I32 gimme = GIMME_V;
 796     static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
 797     static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
 798     static const char an_array[] = "an ARRAY";
 799     static const char a_hash[] = "a HASH";
 800     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
 801     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 802
 803     if (SvROK(sv)) {
 804       wasref:
 805         tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
 806
 807         sv = SvRV(sv);
 808         if (SvTYPE(sv) != type)
 809             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
 810         if (PL_op->op_flags & OPf_REF) {
 811             SETs(sv);
 812             RETURN;
 813         }
 814         else if (LVRET) {
 815             if (gimme != G_ARRAY)
 816                 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
 817                            : return_hash_to_lvalue_scalar);
 818             SETs(sv);
 819             RETURN;
 820         }
 821         else if (PL_op->op_flags & OPf_MOD
 822                 && PL_op->op_private & OPpLVAL_INTRO)
 823             Perl_croak(aTHX_ PL_no_localize_ref);
 824     }
 825     else {
 826         if (SvTYPE(sv) == type) {
 827             if (PL_op->op_flags & OPf_REF) {
 828                 SETs(sv);
 829                 RETURN;
 830             }
 831             else if (LVRET) {
 832                 if (gimme != G_ARRAY)
 833                     Perl_croak(aTHX_
 834                                is_pp_rv2av ? return_array_to_lvalue_scalar
 835                                : return_hash_to_lvalue_scalar);
 836                 SETs(sv);
 837                 RETURN;
 838             }
 839         }
 840         else {
 841             GV *gv;
 842
 843             if (SvTYPE(sv) != SVt_PVGV) {
 844                 if (SvGMAGICAL(sv)) {
 845                     mg_get(sv);
 846                     if (SvROK(sv))
 847                         goto wasref;
 848                 }
 849                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
 850                                      type, &sp);
 851                 if (!gv)
 852                     RETURN;
 853             }
 854             else {
 855                 gv = (GV*)sv;
 856             }
 857             sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
 858             if (PL_op->op_private & OPpLVAL_INTRO)
 859                 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
 860             if (PL_op->op_flags & OPf_REF) {
 861                 SETs(sv);
 862                 RETURN;
 863             }
 864             else if (LVRET) {
 865                 if (gimme != G_ARRAY)
 866                     Perl_croak(aTHX_
 867                                is_pp_rv2av ? return_array_to_lvalue_scalar
 868                                : return_hash_to_lvalue_scalar);
 869                 SETs(sv);
 870                 RETURN;
 871             }
 872         }
 873     }
 874
 875     if (is_pp_rv2av) {
 876         AV *const av = (AV*)sv;
 877         /* The guts of pp_rv2av, with no intenting change to preserve history
 878            (until such time as we get tools that can do blame annotation across
 879            whitespace changes.  */
 880     if (gimme == G_ARRAY) {
 881         const I32 maxarg = AvFILL(av) + 1;
 882         (void)POPs;                     /* XXXX May be optimized away? */
 883         EXTEND(SP, maxarg);
 884         if (SvRMAGICAL(av)) {
 885             U32 i;
 886             for (i=0; i < (U32)maxarg; i++) {
 887                 SV ** const svp = av_fetch(av, i, FALSE);
 888                 /* See note in pp_helem, and bug id #27839 */
 889                 SP[i+1] = svp
 890                     ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
 891                     : &PL_sv_undef;
 892             }
 893         }
 894         else {
 895             Copy(AvARRAY(av), SP+1, maxarg, SV*);
 896         }
 897         SP += maxarg;
 898     }
 899     else if (gimme == G_SCALAR) {
 900         dTARGET;
 901         const I32 maxarg = AvFILL(av) + 1;
 902         SETi(maxarg);
 903     }
 904     } else {
 905         /* The guts of pp_rv2hv  */
 906     if (gimme == G_ARRAY) { /* array wanted */
 907         *PL_stack_sp = sv;
 908         return do_kv();
 909     }
 910     else if (gimme == G_SCALAR) {
 911         dTARGET;
 912     TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
 913         SPAGAIN;
 914         SETTARG;
 915     }
 916     }
 917     RETURN;
 918 }
 919
 920 STATIC void
 921 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 922 {
 923     dVAR;
 924     if (*relem) {
 925         SV *tmpstr;
 926         const HE *didstore;
 927
 928         if (ckWARN(WARN_MISC)) {
 929             const char *err;
 930             if (relem == firstrelem &&
 931                 SvROK(*relem) &&
 932                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 933                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
 934             {
 935                 err = "Reference found where even-sized list expected";
 936             }
 937             else
 938                 err = "Odd number of elements in hash assignment";
 939             Perl_warner(aTHX_ packWARN(WARN_MISC), err);
 940         }
 941
 942         tmpstr = newSV(0);
 943         didstore = hv_store_ent(hash,*relem,tmpstr,0);
 944         if (SvMAGICAL(hash)) {
 945             if (SvSMAGICAL(tmpstr))
 946                 mg_set(tmpstr);
 947             if (!didstore)
 948                 sv_2mortal(tmpstr);
 949         }
 950         TAINT_NOT;
 951     }
 952 }
 953
 954 PP(pp_aassign)
 955 {
 956     dVAR; dSP;
 957     SV **lastlelem = PL_stack_sp;
 958     SV **lastrelem = PL_stack_base + POPMARK;
 959     SV **firstrelem = PL_stack_base + POPMARK + 1;
 960     SV **firstlelem = lastrelem + 1;
 961
 962     register SV **relem;
 963     register SV **lelem;
 964
 965     register SV *sv;
 966     register AV *ary;
 967
 968     I32 gimme;
 969     HV *hash;
 970     I32 i;
 971     int magic;
 972     int duplicates = 0;
 973     SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet  */
 974
 975     if (PL_op->op_private & OPpASSIGN_STATE) {
 976         if (SvPADSTALE(*firstlelem))
 977             SvPADSTALE_off(*firstlelem);
 978         else
 979             RETURN; /* ignore assignment */
 980     }
 981
 982     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
 983     gimme = GIMME_V;
 984
 985     /* If there's a common identifier on both sides we have to take
 986      * special care that assigning the identifier on the left doesn't
 987      * clobber a value on the right that's used later in the list.
 988      */
 989     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
 990         EXTEND_MORTAL(lastrelem - firstrelem + 1);
 991         for (relem = firstrelem; relem <= lastrelem; relem++) {
 992             if ((sv = *relem)) {
 993                 TAINT_NOT;      /* Each item is independent */
 994                 *relem = sv_mortalcopy(sv);
 995             }
 996         }
 997     }
 998
 999     relem = firstrelem;
1000     lelem = firstlelem;
1001     ary = NULL;
1002     hash = NULL;
1003
1004     while (lelem <= lastlelem) {
1005         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1006         sv = *lelem++;
1007         switch (SvTYPE(sv)) {
1008         case SVt_PVAV:
1009             ary = (AV*)sv;
1010             magic = SvMAGICAL(ary) != 0;
1011             av_clear(ary);
1012             av_extend(ary, lastrelem - relem);
1013             i = 0;
1014             while (relem <= lastrelem) {        /* gobble up all the rest */
1015                 SV **didstore;
1016                 assert(*relem);
1017                 sv = newSVsv(*relem);
1018                 *(relem++) = sv;
1019                 didstore = av_store(ary,i++,sv);
1020                 if (magic) {
1021                     if (SvSMAGICAL(sv))
1022                         mg_set(sv);
1023                     if (!didstore)
1024                         sv_2mortal(sv);
1025                 }
1026                 TAINT_NOT;
1027             }
1028             break;
1029         case SVt_PVHV: {                                /* normal hash */
1030                 SV *tmpstr;
1031
1032                 hash = (HV*)sv;
1033                 magic = SvMAGICAL(hash) != 0;
1034                 hv_clear(hash);
1035                 firsthashrelem = relem;
1036
1037                 while (relem < lastrelem) {     /* gobble up all the rest */
1038                     HE *didstore;
1039                     sv = *relem ? *relem : &PL_sv_no;
1040                     relem++;
1041                     tmpstr = newSV(0);
1042                     if (*relem)
1043                         sv_setsv(tmpstr,*relem);        /* value */
1044                     *(relem++) = tmpstr;
1045                     if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1046                         /* key overwrites an existing entry */
1047                         duplicates += 2;
1048                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1049                     if (magic) {
1050                         if (SvSMAGICAL(tmpstr))
1051                             mg_set(tmpstr);
1052                         if (!didstore)
1053                             sv_2mortal(tmpstr);
1054                     }
1055                     TAINT_NOT;
1056                 }
1057                 if (relem == lastrelem) {
1058                     do_oddball(hash, relem, firstrelem);
1059                     relem++;
1060                 }
1061             }
1062             break;
1063         default:
1064             if (SvIMMORTAL(sv)) {
1065                 if (relem <= lastrelem)
1066                     relem++;
1067                 break;
1068             }
1069             if (relem <= lastrelem) {
1070                 sv_setsv(sv, *relem);
1071                 *(relem++) = sv;
1072             }
1073             else
1074                 sv_setsv(sv, &PL_sv_undef);
1075             SvSETMAGIC(sv);
1076             break;
1077         }
1078     }
1079     if (PL_delaymagic & ~DM_DELAY) {
1080         if (PL_delaymagic & DM_UID) {
1081 #ifdef HAS_SETRESUID
1082             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1083                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1084                             (Uid_t)-1);
1085 #else
1086 #  ifdef HAS_SETREUID
1087             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1088                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1089 #  else
1090 #    ifdef HAS_SETRUID
1091             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1092                 (void)setruid(PL_uid);
1093                 PL_delaymagic &= ~DM_RUID;
1094             }
1095 #    endif /* HAS_SETRUID */
1096 #    ifdef HAS_SETEUID
1097             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1098                 (void)seteuid(PL_euid);
1099                 PL_delaymagic &= ~DM_EUID;
1100             }
1101 #    endif /* HAS_SETEUID */
1102             if (PL_delaymagic & DM_UID) {
1103                 if (PL_uid != PL_euid)
1104                     DIE(aTHX_ "No setreuid available");
1105                 (void)PerlProc_setuid(PL_uid);
1106             }
1107 #  endif /* HAS_SETREUID */
1108 #endif /* HAS_SETRESUID */
1109             PL_uid = PerlProc_getuid();
1110             PL_euid = PerlProc_geteuid();
1111         }
1112         if (PL_delaymagic & DM_GID) {
1113 #ifdef HAS_SETRESGID
1114             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1115                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1116                             (Gid_t)-1);
1117 #else
1118 #  ifdef HAS_SETREGID
1119             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1120                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1121 #  else
1122 #    ifdef HAS_SETRGID
1123             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1124                 (void)setrgid(PL_gid);
1125                 PL_delaymagic &= ~DM_RGID;
1126             }
1127 #    endif /* HAS_SETRGID */
1128 #    ifdef HAS_SETEGID
1129             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1130                 (void)setegid(PL_egid);
1131                 PL_delaymagic &= ~DM_EGID;
1132             }
1133 #    endif /* HAS_SETEGID */
1134             if (PL_delaymagic & DM_GID) {
1135                 if (PL_gid != PL_egid)
1136                     DIE(aTHX_ "No setregid available");
1137                 (void)PerlProc_setgid(PL_gid);
1138             }
1139 #  endif /* HAS_SETREGID */
1140 #endif /* HAS_SETRESGID */
1141             PL_gid = PerlProc_getgid();
1142             PL_egid = PerlProc_getegid();
1143         }
1144         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1145     }
1146     PL_delaymagic = 0;
1147
1148     if (gimme == G_VOID)
1149         SP = firstrelem - 1;
1150     else if (gimme == G_SCALAR) {
1151         dTARGET;
1152         SP = firstrelem;
1153         SETi(lastrelem - firstrelem + 1 - duplicates);
1154     }
1155     else {
1156         if (ary)
1157             SP = lastrelem;
1158         else if (hash) {
1159             if (duplicates) {
1160                 /* Removes from the stack the entries which ended up as
1161                  * duplicated keys in the hash (fix for [perl #24380]) */
1162                 Move(firsthashrelem + duplicates,
1163                         firsthashrelem, duplicates, SV**);
1164                 lastrelem -= duplicates;
1165             }
1166             SP = lastrelem;
1167         }
1168         else
1169             SP = firstrelem + (lastlelem - firstlelem);
1170         lelem = firstlelem + (relem - firstrelem);
1171         while (relem <= SP)
1172             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1173     }
1174     RETURN;
1175 }
1176
1177 PP(pp_qr)
1178 {
1179     dVAR; dSP;
1180     register PMOP * const pm = cPMOP;
1181     REGEXP * rx = PM_GETRE(pm);
1182     SV * const pkg = CALLREG_QRPKG(rx);
1183     SV * const rv = sv_newmortal();
1184     SV * const sv = newSVrv(rv, SvPV_nolen(pkg));
1185     if (rx->extflags & RXf_TAINTED)
1186         SvTAINTED_on(rv);
1187     sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
1188     XPUSHs(rv);
1189     RETURN;
1190 }
1191
1192 PP(pp_match)
1193 {
1194     dVAR; dSP; dTARG;
1195     register PMOP *pm = cPMOP;
1196     PMOP *dynpm = pm;
1197     register const char *t;
1198     register const char *s;
1199     const char *strend;
1200     I32 global;
1201     I32 r_flags = REXEC_CHECKED;
1202     const char *truebase;                       /* Start of string  */
1203     register REGEXP *rx = PM_GETRE(pm);
1204     bool rxtainted;
1205     const I32 gimme = GIMME;
1206     STRLEN len;
1207     I32 minmatch = 0;
1208     const I32 oldsave = PL_savestack_ix;
1209     I32 update_minmatch = 1;
1210     I32 had_zerolen = 0;
1211     U32 gpos = 0;
1212
1213     if (PL_op->op_flags & OPf_STACKED)
1214         TARG = POPs;
1215     else if (PL_op->op_private & OPpTARGET_MY)
1216         GETTARGET;
1217     else {
1218         TARG = DEFSV;
1219         EXTEND(SP,1);
1220     }
1221
1222     PUTBACK;                            /* EVAL blocks need stack_sp. */
1223     s = SvPV_const(TARG, len);
1224     if (!s)
1225         DIE(aTHX_ "panic: pp_match");
1226     strend = s + len;
1227     rxtainted = ((rx->extflags & RXf_TAINTED) ||
1228                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1229     TAINT_NOT;
1230
1231     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1232
1233     /* PMdf_USED is set after a ?? matches once */
1234     if (
1235 #ifdef USE_ITHREADS
1236         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1237 #else
1238         pm->op_pmflags & PMf_USED
1239 #endif
1240     ) {
1241       failure:
1242         if (gimme == G_ARRAY)
1243             RETURN;
1244         RETPUSHNO;
1245     }
1246
1247
1248
1249     /* empty pattern special-cased to use last successful pattern if possible */
1250     if (!rx->prelen && PL_curpm) {
1251         pm = PL_curpm;
1252         rx = PM_GETRE(pm);
1253     }
1254
1255     if (rx->minlen > (I32)len)
1256         goto failure;
1257
1258     truebase = t = s;
1259
1260     /* XXXX What part of this is needed with true \G-support? */
1261     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1262         rx->offs[0].start = -1;
1263         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1264             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1265             if (mg && mg->mg_len >= 0) {
1266                 if (!(rx->extflags & RXf_GPOS_SEEN))
1267                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1268                 else if (rx->extflags & RXf_ANCH_GPOS) {
1269                     r_flags |= REXEC_IGNOREPOS;
1270                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1271                 } else if (rx->extflags & RXf_GPOS_FLOAT)
1272                     gpos = mg->mg_len;
1273                 else
1274                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1275                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1276                 update_minmatch = 0;
1277             }
1278         }
1279     }
1280     /* remove comment to get faster /g but possibly unsafe $1 vars after a
1281        match. Test for the unsafe vars will fail as well*/
1282     if (( /* !global &&  */ rx->nparens)
1283             || SvTEMP(TARG) || PL_sawampersand ||
1284             (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1285         r_flags |= REXEC_COPY_STR;
1286     if (SvSCREAM(TARG))
1287         r_flags |= REXEC_SCREAM;
1288
1289 play_it_again:
1290     if (global && rx->offs[0].start != -1) {
1291         t = s = rx->offs[0].end + truebase - rx->gofs;
1292         if ((s + rx->minlen) > strend || s < truebase)
1293             goto nope;
1294         if (update_minmatch++)
1295             minmatch = had_zerolen;
1296     }
1297     if (rx->extflags & RXf_USE_INTUIT &&
1298         DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1299         /* FIXME - can PL_bostr be made const char *?  */
1300         PL_bostr = (char *)truebase;
1301         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1302
1303         if (!s)
1304             goto nope;
1305         if ( (rx->extflags & RXf_CHECK_ALL)
1306              && !PL_sawampersand
1307              && !(rx->extflags & RXf_PMf_KEEPCOPY)
1308              && ((rx->extflags & RXf_NOSCAN)
1309                  || !((rx->extflags & RXf_INTUIT_TAIL)
1310                       && (r_flags & REXEC_SCREAM)))
1311              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1312             goto yup;
1313     }
1314     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1315     {
1316         PL_curpm = pm;
1317         if (dynpm->op_pmflags & PMf_ONCE) {
1318 #ifdef USE_ITHREADS
1319             SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1320 #else
1321             dynpm->op_pmflags |= PMf_USED;
1322 #endif
1323         }
1324         goto gotcha;
1325     }
1326     else
1327         goto ret_no;
1328     /*NOTREACHED*/
1329
1330   gotcha:
1331     if (rxtainted)
1332         RX_MATCH_TAINTED_on(rx);
1333     TAINT_IF(RX_MATCH_TAINTED(rx));
1334     if (gimme == G_ARRAY) {
1335         const I32 nparens = rx->nparens;
1336         I32 i = (global && !nparens) ? 1 : 0;
1337
1338         SPAGAIN;                        /* EVAL blocks could move the stack. */
1339         EXTEND(SP, nparens + i);
1340         EXTEND_MORTAL(nparens + i);
1341         for (i = !i; i <= nparens; i++) {
1342             PUSHs(sv_newmortal());
1343             if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) {
1344                 const I32 len = rx->offs[i].end - rx->offs[i].start;
1345                 s = rx->offs[i].start + truebase;
1346                 if (rx->offs[i].end < 0 || rx->offs[i].start < 0 ||
1347                     len < 0 || len > strend - s)
1348                     DIE(aTHX_ "panic: pp_match start/end pointers");
1349                 sv_setpvn(*SP, s, len);
1350                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1351                     SvUTF8_on(*SP);
1352             }
1353         }
1354         if (global) {
1355             if (dynpm->op_pmflags & PMf_CONTINUE) {
1356                 MAGIC* mg = NULL;
1357                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1358                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1359                 if (!mg) {
1360 #ifdef PERL_OLD_COPY_ON_WRITE
1361                     if (SvIsCOW(TARG))
1362                         sv_force_normal_flags(TARG, 0);
1363 #endif
1364                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1365                                      &PL_vtbl_mglob, NULL, 0);
1366                 }
1367                 if (rx->offs[0].start != -1) {
1368                     mg->mg_len = rx->offs[0].end;
1369                     if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1370                         mg->mg_flags |= MGf_MINMATCH;
1371                     else
1372                         mg->mg_flags &= ~MGf_MINMATCH;
1373                 }
1374             }
1375             had_zerolen = (rx->offs[0].start != -1
1376                            && (rx->offs[0].start + rx->gofs
1377                                == (UV)rx->offs[0].end));
1378             PUTBACK;                    /* EVAL blocks may use stack */
1379             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1380             goto play_it_again;
1381         }
1382         else if (!nparens)
1383             XPUSHs(&PL_sv_yes);
1384         LEAVE_SCOPE(oldsave);
1385         RETURN;
1386     }
1387     else {
1388         if (global) {
1389             MAGIC* mg;
1390             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1391                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1392             else
1393                 mg = NULL;
1394             if (!mg) {
1395 #ifdef PERL_OLD_COPY_ON_WRITE
1396                 if (SvIsCOW(TARG))
1397                     sv_force_normal_flags(TARG, 0);
1398 #endif
1399                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1400                                  &PL_vtbl_mglob, NULL, 0);
1401             }
1402             if (rx->offs[0].start != -1) {
1403                 mg->mg_len = rx->offs[0].end;
1404                 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1405                     mg->mg_flags |= MGf_MINMATCH;
1406                 else
1407                     mg->mg_flags &= ~MGf_MINMATCH;
1408             }
1409         }
1410         LEAVE_SCOPE(oldsave);
1411         RETPUSHYES;
1412     }
1413
1414 yup:                                    /* Confirmed by INTUIT */
1415     if (rxtainted)
1416         RX_MATCH_TAINTED_on(rx);
1417     TAINT_IF(RX_MATCH_TAINTED(rx));
1418     PL_curpm = pm;
1419     if (dynpm->op_pmflags & PMf_ONCE) {
1420 #ifdef USE_ITHREADS
1421         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1422 #else
1423         dynpm->op_pmflags |= PMf_USED;
1424 #endif
1425     }
1426     if (RX_MATCH_COPIED(rx))
1427         Safefree(rx->subbeg);
1428     RX_MATCH_COPIED_off(rx);
1429     rx->subbeg = NULL;
1430     if (global) {
1431         /* FIXME - should rx->subbeg be const char *?  */
1432         rx->subbeg = (char *) truebase;
1433         rx->offs[0].start = s - truebase;
1434         if (RX_MATCH_UTF8(rx)) {
1435             char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1436             rx->offs[0].end = t - truebase;
1437         }
1438         else {
1439             rx->offs[0].end = s - truebase + rx->minlenret;
1440         }
1441         rx->sublen = strend - truebase;
1442         goto gotcha;
1443     }
1444     if (PL_sawampersand || rx->extflags & RXf_PMf_KEEPCOPY) {
1445         I32 off;
1446 #ifdef PERL_OLD_COPY_ON_WRITE
1447         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1448             if (DEBUG_C_TEST) {
1449                 PerlIO_printf(Perl_debug_log,
1450                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1451                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1452                               (int)(t-truebase));
1453             }
1454             rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1455             rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1456             assert (SvPOKp(rx->saved_copy));
1457         } else
1458 #endif
1459         {
1460
1461             rx->subbeg = savepvn(t, strend - t);
1462 #ifdef PERL_OLD_COPY_ON_WRITE
1463             rx->saved_copy = NULL;
1464 #endif
1465         }
1466         rx->sublen = strend - t;
1467         RX_MATCH_COPIED_on(rx);
1468         off = rx->offs[0].start = s - t;
1469         rx->offs[0].end = off + rx->minlenret;
1470     }
1471     else {                      /* startp/endp are used by @- @+. */
1472         rx->offs[0].start = s - truebase;
1473         rx->offs[0].end = s - truebase + rx->minlenret;
1474     }
1475     /* including rx->nparens in the below code seems highly suspicious.
1476        -dmq */
1477     rx->nparens = rx->lastparen = rx->lastcloseparen = 0;       /* used by @-, @+, and $^N */
1478     LEAVE_SCOPE(oldsave);
1479     RETPUSHYES;
1480
1481 nope:
1482 ret_no:
1483     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1484         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1485             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1486             if (mg)
1487                 mg->mg_len = -1;
1488         }
1489     }
1490     LEAVE_SCOPE(oldsave);
1491     if (gimme == G_ARRAY)
1492         RETURN;
1493     RETPUSHNO;
1494 }
1495
1496 OP *
1497 Perl_do_readline(pTHX)
1498 {
1499     dVAR; dSP; dTARGETSTACKED;
1500     register SV *sv;
1501     STRLEN tmplen = 0;
1502     STRLEN offset;
1503     PerlIO *fp;
1504     register IO * const io = GvIO(PL_last_in_gv);
1505     register const I32 type = PL_op->op_type;
1506     const I32 gimme = GIMME_V;
1507
1508     if (io) {
1509         MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1510         if (mg) {
1511             PUSHMARK(SP);
1512             XPUSHs(SvTIED_obj((SV*)io, mg));
1513             PUTBACK;
1514             ENTER;
1515             call_method("READLINE", gimme);
1516             LEAVE;
1517             SPAGAIN;
1518             if (gimme == G_SCALAR) {
1519                 SV* const result = POPs;
1520                 SvSetSV_nosteal(TARG, result);
1521                 PUSHTARG;
1522             }
1523             RETURN;
1524         }
1525     }
1526     fp = NULL;
1527     if (io) {
1528         fp = IoIFP(io);
1529         if (!fp) {
1530             if (IoFLAGS(io) & IOf_ARGV) {
1531                 if (IoFLAGS(io) & IOf_START) {
1532                     IoLINES(io) = 0;
1533                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1534                         IoFLAGS(io) &= ~IOf_START;
1535                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1536                         sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1537                         SvSETMAGIC(GvSV(PL_last_in_gv));
1538                         fp = IoIFP(io);
1539                         goto have_fp;
1540                     }
1541                 }
1542                 fp = nextargv(PL_last_in_gv);
1543                 if (!fp) { /* Note: fp != IoIFP(io) */
1544                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1545                 }
1546             }
1547             else if (type == OP_GLOB)
1548                 fp = Perl_start_glob(aTHX_ POPs, io);
1549         }
1550         else if (type == OP_GLOB)
1551             SP--;
1552         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1553             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1554         }
1555     }
1556     if (!fp) {
1557         if ((!io || !(IoFLAGS(io) & IOf_START))
1558             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1559         {
1560             if (type == OP_GLOB)
1561                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1562                             "glob failed (can't start child: %s)",
1563                             Strerror(errno));
1564             else
1565                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1566         }
1567         if (gimme == G_SCALAR) {
1568             /* undef TARG, and push that undefined value */
1569             if (type != OP_RCATLINE) {
1570                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1571                 SvOK_off(TARG);
1572             }
1573             PUSHTARG;
1574         }
1575         RETURN;
1576     }
1577   have_fp:
1578     if (gimme == G_SCALAR) {
1579         sv = TARG;
1580         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1581             mg_get(sv);
1582         if (SvROK(sv)) {
1583             if (type == OP_RCATLINE)
1584                 SvPV_force_nolen(sv);
1585             else
1586                 sv_unref(sv);
1587         }
1588         else if (isGV_with_GP(sv)) {
1589             SvPV_force_nolen(sv);
1590         }
1591         SvUPGRADE(sv, SVt_PV);
1592         tmplen = SvLEN(sv);     /* remember if already alloced */
1593         if (!tmplen && !SvREADONLY(sv))
1594             Sv_Grow(sv, 80);    /* try short-buffering it */
1595         offset = 0;
1596         if (type == OP_RCATLINE && SvOK(sv)) {
1597             if (!SvPOK(sv)) {
1598                 SvPV_force_nolen(sv);
1599             }
1600             offset = SvCUR(sv);
1601         }
1602     }
1603     else {
1604         sv = sv_2mortal(newSV(80));
1605         offset = 0;
1606     }
1607
1608     /* This should not be marked tainted if the fp is marked clean */
1609 #define MAYBE_TAINT_LINE(io, sv) \
1610     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1611         TAINT;                          \
1612         SvTAINTED_on(sv);               \
1613     }
1614
1615 /* delay EOF state for a snarfed empty file */
1616 #define SNARF_EOF(gimme,rs,io,sv) \
1617     (gimme != G_SCALAR || SvCUR(sv)                                     \
1618      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1619
1620     for (;;) {
1621         PUTBACK;
1622         if (!sv_gets(sv, fp, offset)
1623             && (type == OP_GLOB
1624                 || SNARF_EOF(gimme, PL_rs, io, sv)
1625                 || PerlIO_error(fp)))
1626         {
1627             PerlIO_clearerr(fp);
1628             if (IoFLAGS(io) & IOf_ARGV) {
1629                 fp = nextargv(PL_last_in_gv);
1630                 if (fp)
1631                     continue;
1632                 (void)do_close(PL_last_in_gv, FALSE);
1633             }
1634             else if (type == OP_GLOB) {
1635                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1636                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1637                            "glob failed (child exited with status %d%s)",
1638                            (int)(STATUS_CURRENT >> 8),
1639                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1640                 }
1641             }
1642             if (gimme == G_SCALAR) {
1643                 if (type != OP_RCATLINE) {
1644                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1645                     SvOK_off(TARG);
1646                 }
1647                 SPAGAIN;
1648                 PUSHTARG;
1649             }
1650             MAYBE_TAINT_LINE(io, sv);
1651             RETURN;
1652         }
1653         MAYBE_TAINT_LINE(io, sv);
1654         IoLINES(io)++;
1655         IoFLAGS(io) |= IOf_NOLINE;
1656         SvSETMAGIC(sv);
1657         SPAGAIN;
1658         XPUSHs(sv);
1659         if (type == OP_GLOB) {
1660             const char *t1;
1661
1662             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1663                 char * const tmps = SvEND(sv) - 1;
1664                 if (*tmps == *SvPVX_const(PL_rs)) {
1665                     *tmps = '\0';
1666                     SvCUR_set(sv, SvCUR(sv) - 1);
1667                 }
1668             }
1669             for (t1 = SvPVX_const(sv); *t1; t1++)
1670                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1671                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1672                         break;
1673             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1674                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1675                 continue;
1676             }
1677         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1678              if (ckWARN(WARN_UTF8)) {
1679                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1680                 const STRLEN len = SvCUR(sv) - offset;
1681                 const U8 *f;
1682
1683                 if (!is_utf8_string_loc(s, len, &f))
1684                     /* Emulate :encoding(utf8) warning in the same case. */
1685                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1686                                 "utf8 \"\\x%02X\" does not map to Unicode",
1687                                 f < (U8*)SvEND(sv) ? *f : 0);
1688              }
1689         }
1690         if (gimme == G_ARRAY) {
1691             if (SvLEN(sv) - SvCUR(sv) > 20) {
1692                 SvPV_shrink_to_cur(sv);
1693             }
1694             sv = sv_2mortal(newSV(80));
1695             continue;
1696         }
1697         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1698             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1699             const STRLEN new_len
1700                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1701             SvPV_renew(sv, new_len);
1702         }
1703         RETURN;
1704     }
1705 }
1706
1707 PP(pp_enter)
1708 {
1709     dVAR; dSP;
1710     register PERL_CONTEXT *cx;
1711     I32 gimme = OP_GIMME(PL_op, -1);
1712
1713     if (gimme == -1) {
1714         if (cxstack_ix >= 0)
1715             gimme = cxstack[cxstack_ix].blk_gimme;
1716         else
1717             gimme = G_SCALAR;
1718     }
1719
1720     ENTER;
1721
1722     SAVETMPS;
1723     PUSHBLOCK(cx, CXt_BLOCK, SP);
1724
1725     RETURN;
1726 }
1727
1728 PP(pp_helem)
1729 {
1730     dVAR; dSP;
1731     HE* he;
1732     SV **svp;
1733     SV * const keysv = POPs;
1734     HV * const hv = (HV*)POPs;
1735     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1736     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1737     SV *sv;
1738     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1739     I32 preeminent = 0;
1740
1741     if (SvTYPE(hv) != SVt_PVHV)
1742         RETPUSHUNDEF;
1743
1744     if (PL_op->op_private & OPpLVAL_INTRO) {
1745         MAGIC *mg;
1746         HV *stash;
1747         /* does the element we're localizing already exist? */
1748         preeminent = /* can we determine whether it exists? */
1749             (    !SvRMAGICAL(hv)
1750                 || mg_find((SV*)hv, PERL_MAGIC_env)
1751                 || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1752                         /* Try to preserve the existenceness of a tied hash
1753                         * element by using EXISTS and DELETE if possible.
1754                         * Fallback to FETCH and STORE otherwise */
1755                     && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1756                     && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1757                     && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1758                 )
1759             ) ? hv_exists_ent(hv, keysv, 0) : 1;
1760     }
1761     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1762     svp = he ? &HeVAL(he) : NULL;
1763     if (lval) {
1764         if (!svp || *svp == &PL_sv_undef) {
1765             SV* lv;
1766             SV* key2;
1767             if (!defer) {
1768                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1769             }
1770             lv = sv_newmortal();
1771             sv_upgrade(lv, SVt_PVLV);
1772             LvTYPE(lv) = 'y';
1773             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1774             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1775             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1776             LvTARGLEN(lv) = 1;
1777             PUSHs(lv);
1778             RETURN;
1779         }
1780         if (PL_op->op_private & OPpLVAL_INTRO) {
1781             if (HvNAME_get(hv) && isGV(*svp))
1782                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1783             else {
1784                 if (!preeminent) {
1785                     STRLEN keylen;
1786                     const char * const key = SvPV_const(keysv, keylen);
1787                     SAVEDELETE(hv, savepvn(key,keylen),
1788                                SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1789                 } else
1790                     save_helem(hv, keysv, svp);
1791             }
1792         }
1793         else if (PL_op->op_private & OPpDEREF)
1794             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1795     }
1796     sv = (svp ? *svp : &PL_sv_undef);
1797     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1798      * Pushing the magical RHS on to the stack is useless, since
1799      * that magic is soon destined to be misled by the local(),
1800      * and thus the later pp_sassign() will fail to mg_get() the
1801      * old value.  This should also cure problems with delayed
1802      * mg_get()s.  GSAR 98-07-03 */
1803     if (!lval && SvGMAGICAL(sv))
1804         sv = sv_mortalcopy(sv);
1805     PUSHs(sv);
1806     RETURN;
1807 }
1808
1809 PP(pp_leave)
1810 {
1811     dVAR; dSP;
1812     register PERL_CONTEXT *cx;
1813     SV **newsp;
1814     PMOP *newpm;
1815     I32 gimme;
1816
1817     if (PL_op->op_flags & OPf_SPECIAL) {
1818         cx = &cxstack[cxstack_ix];
1819         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1820     }
1821
1822     POPBLOCK(cx,newpm);
1823
1824     gimme = OP_GIMME(PL_op, -1);
1825     if (gimme == -1) {
1826         if (cxstack_ix >= 0)
1827             gimme = cxstack[cxstack_ix].blk_gimme;
1828         else
1829             gimme = G_SCALAR;
1830     }
1831
1832     TAINT_NOT;
1833     if (gimme == G_VOID)
1834         SP = newsp;
1835     else if (gimme == G_SCALAR) {
1836         register SV **mark;
1837         MARK = newsp + 1;
1838         if (MARK <= SP) {
1839             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1840                 *MARK = TOPs;
1841             else
1842                 *MARK = sv_mortalcopy(TOPs);
1843         } else {
1844             MEXTEND(mark,0);
1845             *MARK = &PL_sv_undef;
1846         }
1847         SP = MARK;
1848     }
1849     else if (gimme == G_ARRAY) {
1850         /* in case LEAVE wipes old return values */
1851         register SV **mark;
1852         for (mark = newsp + 1; mark <= SP; mark++) {
1853             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1854                 *mark = sv_mortalcopy(*mark);
1855                 TAINT_NOT;      /* Each item is independent */
1856             }
1857         }
1858     }
1859     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1860
1861     LEAVE;
1862
1863     RETURN;
1864 }
1865
1866 PP(pp_iter)
1867 {
1868     dVAR; dSP;
1869     register PERL_CONTEXT *cx;
1870     SV *sv, *oldsv;
1871     AV* av;
1872     SV **itersvp;
1873
1874     EXTEND(SP, 1);
1875     cx = &cxstack[cxstack_ix];
1876     if (CxTYPE(cx) != CXt_LOOP)
1877         DIE(aTHX_ "panic: pp_iter");
1878
1879     itersvp = CxITERVAR(cx);
1880     av = cx->blk_loop.iterary;
1881     if (SvTYPE(av) != SVt_PVAV) {
1882         /* iterate ($min .. $max) */
1883         if (cx->blk_loop.iterlval) {
1884             /* string increment */
1885             register SV* cur = cx->blk_loop.iterlval;
1886             STRLEN maxlen = 0;
1887             const char *max =
1888               SvOK((SV*)av) ?
1889               SvPV_const((SV*)av, maxlen) : (const char *)"";
1890             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1891                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1892                     /* safe to reuse old SV */
1893                     sv_setsv(*itersvp, cur);
1894                 }
1895                 else
1896                 {
1897                     /* we need a fresh SV every time so that loop body sees a
1898                      * completely new SV for closures/references to work as
1899                      * they used to */
1900                     oldsv = *itersvp;
1901                     *itersvp = newSVsv(cur);
1902                     SvREFCNT_dec(oldsv);
1903                 }
1904                 if (strEQ(SvPVX_const(cur), max))
1905                     sv_setiv(cur, 0); /* terminate next time */
1906                 else
1907                     sv_inc(cur);
1908                 RETPUSHYES;
1909             }
1910             RETPUSHNO;
1911         }
1912         /* integer increment */
1913         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1914             RETPUSHNO;
1915
1916         /* don't risk potential race */
1917         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1918             /* safe to reuse old SV */
1919             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1920         }
1921         else
1922         {
1923             /* we need a fresh SV every time so that loop body sees a
1924              * completely new SV for closures/references to work as they
1925              * used to */
1926             oldsv = *itersvp;
1927             *itersvp = newSViv(cx->blk_loop.iterix++);
1928             SvREFCNT_dec(oldsv);
1929         }
1930         RETPUSHYES;
1931     }
1932
1933     /* iterate array */
1934     if (PL_op->op_private & OPpITER_REVERSED) {
1935         /* In reverse, use itermax as the min :-)  */
1936         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1937             RETPUSHNO;
1938
1939         if (SvMAGICAL(av) || AvREIFY(av)) {
1940             SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1941             sv = svp ? *svp : NULL;
1942         }
1943         else {
1944             sv = AvARRAY(av)[--cx->blk_loop.iterix];
1945         }
1946     }
1947     else {
1948         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1949                                     AvFILL(av)))
1950             RETPUSHNO;
1951
1952         if (SvMAGICAL(av) || AvREIFY(av)) {
1953             SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1954             sv = svp ? *svp : NULL;
1955         }
1956         else {
1957             sv = AvARRAY(av)[++cx->blk_loop.iterix];
1958         }
1959     }
1960
1961     if (sv && SvIS_FREED(sv)) {
1962         *itersvp = NULL;
1963         Perl_croak(aTHX_ "Use of freed value in iteration");
1964     }
1965
1966     if (sv)
1967         SvTEMP_off(sv);
1968     else
1969         sv = &PL_sv_undef;
1970     if (av != PL_curstack && sv == &PL_sv_undef) {
1971         SV *lv = cx->blk_loop.iterlval;
1972         if (lv && SvREFCNT(lv) > 1) {
1973             SvREFCNT_dec(lv);
1974             lv = NULL;
1975         }
1976         if (lv)
1977             SvREFCNT_dec(LvTARG(lv));
1978         else {
1979             lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
1980             LvTYPE(lv) = 'y';
1981             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1982         }
1983         LvTARG(lv) = SvREFCNT_inc_simple(av);
1984         LvTARGOFF(lv) = cx->blk_loop.iterix;
1985         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1986         sv = (SV*)lv;
1987     }
1988
1989     oldsv = *itersvp;
1990     *itersvp = SvREFCNT_inc_simple_NN(sv);
1991     SvREFCNT_dec(oldsv);
1992
1993     RETPUSHYES;
1994 }
1995
1996 PP(pp_subst)
1997 {
1998     dVAR; dSP; dTARG;
1999     register PMOP *pm = cPMOP;
2000     PMOP *rpm = pm;
2001     register char *s;
2002     char *strend;
2003     register char *m;
2004     const char *c;
2005     register char *d;
2006     STRLEN clen;
2007     I32 iters = 0;
2008     I32 maxiters;
2009     register I32 i;
2010     bool once;
2011     bool rxtainted;
2012     char *orig;
2013     I32 r_flags;
2014     register REGEXP *rx = PM_GETRE(pm);
2015     STRLEN len;
2016     int force_on_match = 0;
2017     const I32 oldsave = PL_savestack_ix;
2018     STRLEN slen;
2019     bool doutf8 = FALSE;
2020 #ifdef PERL_OLD_COPY_ON_WRITE
2021     bool is_cow;
2022 #endif
2023     SV *nsv = NULL;
2024
2025     /* known replacement string? */
2026     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2027     if (PL_op->op_flags & OPf_STACKED)
2028         TARG = POPs;
2029     else if (PL_op->op_private & OPpTARGET_MY)
2030         GETTARGET;
2031     else {
2032         TARG = DEFSV;
2033         EXTEND(SP,1);
2034     }
2035
2036 #ifdef PERL_OLD_COPY_ON_WRITE
2037     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2038        because they make integers such as 256 "false".  */
2039     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2040 #else
2041     if (SvIsCOW(TARG))
2042         sv_force_normal_flags(TARG,0);
2043 #endif
2044     if (
2045 #ifdef PERL_OLD_COPY_ON_WRITE
2046         !is_cow &&
2047 #endif
2048         (SvREADONLY(TARG)
2049          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2050                || SvTYPE(TARG) > SVt_PVLV)
2051              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2052         DIE(aTHX_ PL_no_modify);
2053     PUTBACK;
2054
2055     s = SvPV_mutable(TARG, len);
2056     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2057         force_on_match = 1;
2058     rxtainted = ((rx->extflags & RXf_TAINTED) ||
2059                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2060     if (PL_tainted)
2061         rxtainted |= 2;
2062     TAINT_NOT;
2063
2064     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2065
2066   force_it:
2067     if (!pm || !s)
2068         DIE(aTHX_ "panic: pp_subst");
2069
2070     strend = s + len;
2071     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2072     maxiters = 2 * slen + 10;   /* We can match twice at each
2073                                    position, once with zero-length,
2074                                    second time with non-zero. */
2075
2076     if (!rx->prelen && PL_curpm) {
2077         pm = PL_curpm;
2078         rx = PM_GETRE(pm);
2079     }
2080     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2081             || (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2082                ? REXEC_COPY_STR : 0;
2083     if (SvSCREAM(TARG))
2084         r_flags |= REXEC_SCREAM;
2085
2086     orig = m = s;
2087     if (rx->extflags & RXf_USE_INTUIT) {
2088         PL_bostr = orig;
2089         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2090
2091         if (!s)
2092             goto nope;
2093         /* How to do it in subst? */
2094 /*      if ( (rx->extflags & RXf_CHECK_ALL)
2095              && !PL_sawampersand
2096              && !(rx->extflags & RXf_KEEPCOPY)
2097              && ((rx->extflags & RXf_NOSCAN)
2098                  || !((rx->extflags & RXf_INTUIT_TAIL)
2099                       && (r_flags & REXEC_SCREAM))))
2100             goto yup;
2101 */
2102     }
2103
2104     /* only replace once? */
2105     once = !(rpm->op_pmflags & PMf_GLOBAL);
2106
2107     /* known replacement string? */
2108     if (dstr) {
2109         /* replacement needing upgrading? */
2110         if (DO_UTF8(TARG) && !doutf8) {
2111              nsv = sv_newmortal();
2112              SvSetSV(nsv, dstr);
2113              if (PL_encoding)
2114                   sv_recode_to_utf8(nsv, PL_encoding);
2115              else
2116                   sv_utf8_upgrade(nsv);
2117              c = SvPV_const(nsv, clen);
2118              doutf8 = TRUE;
2119         }
2120         else {
2121             c = SvPV_const(dstr, clen);
2122             doutf8 = DO_UTF8(dstr);
2123         }
2124     }
2125     else {
2126         c = NULL;
2127         doutf8 = FALSE;
2128     }
2129
2130     /* can do inplace substitution? */
2131     if (c
2132 #ifdef PERL_OLD_COPY_ON_WRITE
2133         && !is_cow
2134 #endif
2135         && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2136         && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2137         && (!doutf8 || SvUTF8(TARG))) {
2138         if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2139                          r_flags | REXEC_CHECKED))
2140         {
2141             SPAGAIN;
2142             PUSHs(&PL_sv_no);
2143             LEAVE_SCOPE(oldsave);
2144             RETURN;
2145         }
2146 #ifdef PERL_OLD_COPY_ON_WRITE
2147         if (SvIsCOW(TARG)) {
2148             assert (!force_on_match);
2149             goto have_a_cow;
2150         }
2151 #endif
2152         if (force_on_match) {
2153             force_on_match = 0;
2154             s = SvPV_force(TARG, len);
2155             goto force_it;
2156         }
2157         d = s;
2158         PL_curpm = pm;
2159         SvSCREAM_off(TARG);     /* disable possible screamer */
2160         if (once) {
2161             rxtainted |= RX_MATCH_TAINTED(rx);
2162             m = orig + rx->offs[0].start;
2163             d = orig + rx->offs[0].end;
2164             s = orig;
2165             if (m - s > strend - d) {  /* faster to shorten from end */
2166                 if (clen) {
2167                     Copy(c, m, clen, char);
2168                     m += clen;
2169                 }
2170                 i = strend - d;
2171                 if (i > 0) {
2172                     Move(d, m, i, char);
2173                     m += i;
2174                 }
2175                 *m = '\0';
2176                 SvCUR_set(TARG, m - s);
2177             }
2178             else if ((i = m - s)) {     /* faster from front */
2179                 d -= clen;
2180                 m = d;
2181                 sv_chop(TARG, d-i);
2182                 s += i;
2183                 while (i--)
2184                     *--d = *--s;
2185                 if (clen)
2186                     Copy(c, m, clen, char);
2187             }
2188             else if (clen) {
2189                 d -= clen;
2190                 sv_chop(TARG, d);
2191                 Copy(c, d, clen, char);
2192             }
2193             else {
2194                 sv_chop(TARG, d);
2195             }
2196             TAINT_IF(rxtainted & 1);
2197             SPAGAIN;
2198             PUSHs(&PL_sv_yes);
2199         }
2200         else {
2201             do {
2202                 if (iters++ > maxiters)
2203                     DIE(aTHX_ "Substitution loop");
2204                 rxtainted |= RX_MATCH_TAINTED(rx);
2205                 m = rx->offs[0].start + orig;
2206                 if ((i = m - s)) {
2207                     if (s != d)
2208                         Move(s, d, i, char);
2209                     d += i;
2210                 }
2211                 if (clen) {
2212                     Copy(c, d, clen, char);
2213                     d += clen;
2214                 }
2215                 s = rx->offs[0].end + orig;
2216             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2217                                  TARG, NULL,
2218                                  /* don't match same null twice */
2219                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2220             if (s != d) {
2221                 i = strend - s;
2222                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2223                 Move(s, d, i+1, char);          /* include the NUL */
2224             }
2225             TAINT_IF(rxtainted & 1);
2226             SPAGAIN;
2227             PUSHs(sv_2mortal(newSViv((I32)iters)));
2228         }
2229         (void)SvPOK_only_UTF8(TARG);
2230         TAINT_IF(rxtainted);
2231         if (SvSMAGICAL(TARG)) {
2232             PUTBACK;
2233             mg_set(TARG);
2234             SPAGAIN;
2235         }
2236         SvTAINT(TARG);
2237         if (doutf8)
2238             SvUTF8_on(TARG);
2239         LEAVE_SCOPE(oldsave);
2240         RETURN;
2241     }
2242
2243     if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2244                     r_flags | REXEC_CHECKED))
2245     {
2246         if (force_on_match) {
2247             force_on_match = 0;
2248             s = SvPV_force(TARG, len);
2249             goto force_it;
2250         }
2251 #ifdef PERL_OLD_COPY_ON_WRITE
2252       have_a_cow:
2253 #endif
2254         rxtainted |= RX_MATCH_TAINTED(rx);
2255         dstr = newSVpvn(m, s-m);
2256         SAVEFREESV(dstr);
2257         if (DO_UTF8(TARG))
2258             SvUTF8_on(dstr);
2259         PL_curpm = pm;
2260         if (!c) {
2261             register PERL_CONTEXT *cx;
2262             SPAGAIN;
2263             PUSHSUBST(cx);
2264             RETURNOP(cPMOP->op_pmreplroot);
2265         }
2266         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2267         do {
2268             if (iters++ > maxiters)
2269                 DIE(aTHX_ "Substitution loop");
2270             rxtainted |= RX_MATCH_TAINTED(rx);
2271             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2272                 m = s;
2273                 s = orig;
2274                 orig = rx->subbeg;
2275                 s = orig + (m - s);
2276                 strend = s + (strend - m);
2277             }
2278             m = rx->offs[0].start + orig;
2279             if (doutf8 && !SvUTF8(dstr))
2280                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2281             else
2282                 sv_catpvn(dstr, s, m-s);
2283             s = rx->offs[0].end + orig;
2284             if (clen)
2285                 sv_catpvn(dstr, c, clen);
2286             if (once)
2287                 break;
2288         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2289                              TARG, NULL, r_flags));
2290         if (doutf8 && !DO_UTF8(TARG))
2291             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2292         else
2293             sv_catpvn(dstr, s, strend - s);
2294
2295 #ifdef PERL_OLD_COPY_ON_WRITE
2296         /* The match may make the string COW. If so, brilliant, because that's
2297            just saved us one malloc, copy and free - the regexp has donated
2298            the old buffer, and we malloc an entirely new one, rather than the
2299            regexp malloc()ing a buffer and copying our original, only for
2300            us to throw it away here during the substitution.  */
2301         if (SvIsCOW(TARG)) {
2302             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2303         } else
2304 #endif
2305         {
2306             SvPV_free(TARG);
2307         }
2308         SvPV_set(TARG, SvPVX(dstr));
2309         SvCUR_set(TARG, SvCUR(dstr));
2310         SvLEN_set(TARG, SvLEN(dstr));
2311         doutf8 |= DO_UTF8(dstr);
2312         SvPV_set(dstr, NULL);
2313
2314         TAINT_IF(rxtainted & 1);
2315         SPAGAIN;
2316         PUSHs(sv_2mortal(newSViv((I32)iters)));
2317
2318         (void)SvPOK_only(TARG);
2319         if (doutf8)
2320             SvUTF8_on(TARG);
2321         TAINT_IF(rxtainted);
2322         SvSETMAGIC(TARG);
2323         SvTAINT(TARG);
2324         LEAVE_SCOPE(oldsave);
2325         RETURN;
2326     }
2327     goto ret_no;
2328
2329 nope:
2330 ret_no:
2331     SPAGAIN;
2332     PUSHs(&PL_sv_no);
2333     LEAVE_SCOPE(oldsave);
2334     RETURN;
2335 }
2336
2337 PP(pp_grepwhile)
2338 {
2339     dVAR; dSP;
2340
2341     if (SvTRUEx(POPs))
2342         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2343     ++*PL_markstack_ptr;
2344     LEAVE;                                      /* exit inner scope */
2345
2346     /* All done yet? */
2347     if (PL_stack_base + *PL_markstack_ptr > SP) {
2348         I32 items;
2349         const I32 gimme = GIMME_V;
2350
2351         LEAVE;                                  /* exit outer scope */
2352         (void)POPMARK;                          /* pop src */
2353         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2354         (void)POPMARK;                          /* pop dst */
2355         SP = PL_stack_base + POPMARK;           /* pop original mark */
2356         if (gimme == G_SCALAR) {
2357             if (PL_op->op_private & OPpGREP_LEX) {
2358                 SV* const sv = sv_newmortal();
2359                 sv_setiv(sv, items);
2360                 PUSHs(sv);
2361             }
2362             else {
2363                 dTARGET;
2364                 XPUSHi(items);
2365             }
2366         }
2367         else if (gimme == G_ARRAY)
2368             SP += items;
2369         RETURN;
2370     }
2371     else {
2372         SV *src;
2373
2374         ENTER;                                  /* enter inner scope */
2375         SAVEVPTR(PL_curpm);
2376
2377         src = PL_stack_base[*PL_markstack_ptr];
2378         SvTEMP_off(src);
2379         if (PL_op->op_private & OPpGREP_LEX)
2380             PAD_SVl(PL_op->op_targ) = src;
2381         else
2382             DEFSV = src;
2383
2384         RETURNOP(cLOGOP->op_other);
2385     }
2386 }
2387
2388 PP(pp_leavesub)
2389 {
2390     dVAR; dSP;
2391     SV **mark;
2392     SV **newsp;
2393     PMOP *newpm;
2394     I32 gimme;
2395     register PERL_CONTEXT *cx;
2396     SV *sv;
2397
2398     if (CxMULTICALL(&cxstack[cxstack_ix]))
2399         return 0;
2400
2401     POPBLOCK(cx,newpm);
2402     cxstack_ix++; /* temporarily protect top context */
2403
2404     TAINT_NOT;
2405     if (gimme == G_SCALAR) {
2406         MARK = newsp + 1;
2407         if (MARK <= SP) {
2408             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2409                 if (SvTEMP(TOPs)) {
2410                     *MARK = SvREFCNT_inc(TOPs);
2411                     FREETMPS;
2412                     sv_2mortal(*MARK);
2413                 }
2414                 else {
2415                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2416                     FREETMPS;
2417                     *MARK = sv_mortalcopy(sv);
2418                     SvREFCNT_dec(sv);
2419                 }
2420             }
2421             else
2422                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2423         }
2424         else {
2425             MEXTEND(MARK, 0);
2426             *MARK = &PL_sv_undef;
2427         }
2428         SP = MARK;
2429     }
2430     else if (gimme == G_ARRAY) {
2431         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2432             if (!SvTEMP(*MARK)) {
2433                 *MARK = sv_mortalcopy(*MARK);
2434                 TAINT_NOT;      /* Each item is independent */
2435             }
2436         }
2437     }
2438     PUTBACK;
2439
2440     LEAVE;
2441     cxstack_ix--;
2442     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2443     PL_curpm = newpm;   /* ... and pop $1 et al */
2444
2445     LEAVESUB(sv);
2446     return cx->blk_sub.retop;
2447 }
2448
2449 /* This duplicates the above code because the above code must not
2450  * get any slower by more conditions */
2451 PP(pp_leavesublv)
2452 {
2453     dVAR; dSP;
2454     SV **mark;
2455     SV **newsp;
2456     PMOP *newpm;
2457     I32 gimme;
2458     register PERL_CONTEXT *cx;
2459     SV *sv;
2460
2461     if (CxMULTICALL(&cxstack[cxstack_ix]))
2462         return 0;
2463
2464     POPBLOCK(cx,newpm);
2465     cxstack_ix++; /* temporarily protect top context */
2466
2467     TAINT_NOT;
2468
2469     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2470         /* We are an argument to a function or grep().
2471          * This kind of lvalueness was legal before lvalue
2472          * subroutines too, so be backward compatible:
2473          * cannot report errors.  */
2474
2475         /* Scalar context *is* possible, on the LHS of -> only,
2476          * as in f()->meth().  But this is not an lvalue. */
2477         if (gimme == G_SCALAR)
2478             goto temporise;
2479         if (gimme == G_ARRAY) {
2480             if (!CvLVALUE(cx->blk_sub.cv))
2481                 goto temporise_array;
2482             EXTEND_MORTAL(SP - newsp);
2483             for (mark = newsp + 1; mark <= SP; mark++) {
2484                 if (SvTEMP(*mark))
2485                     NOOP;
2486                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2487                     *mark = sv_mortalcopy(*mark);
2488                 else {
2489                     /* Can be a localized value subject to deletion. */
2490                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2491                     SvREFCNT_inc_void(*mark);
2492                 }
2493             }
2494         }
2495     }
2496     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2497         /* Here we go for robustness, not for speed, so we change all
2498          * the refcounts so the caller gets a live guy. Cannot set
2499          * TEMP, so sv_2mortal is out of question. */
2500         if (!CvLVALUE(cx->blk_sub.cv)) {
2501             LEAVE;
2502             cxstack_ix--;
2503             POPSUB(cx,sv);
2504             PL_curpm = newpm;
2505             LEAVESUB(sv);
2506             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2507         }
2508         if (gimme == G_SCALAR) {
2509             MARK = newsp + 1;
2510             EXTEND_MORTAL(1);
2511             if (MARK == SP) {
2512                 /* Temporaries are bad unless they happen to be elements
2513                  * of a tied hash or array */
2514                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2515                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2516                     LEAVE;
2517                     cxstack_ix--;
2518                     POPSUB(cx,sv);
2519                     PL_curpm = newpm;
2520                     LEAVESUB(sv);
2521                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2522                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2523                         : "a readonly value" : "a temporary");
2524                 }
2525                 else {                  /* Can be a localized value
2526                                          * subject to deletion. */
2527                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2528                     SvREFCNT_inc_void(*mark);
2529                 }
2530             }
2531             else {                      /* Should not happen? */
2532                 LEAVE;
2533                 cxstack_ix--;
2534                 POPSUB(cx,sv);
2535                 PL_curpm = newpm;
2536                 LEAVESUB(sv);
2537                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2538                     (MARK > SP ? "Empty array" : "Array"));
2539             }
2540             SP = MARK;
2541         }
2542         else if (gimme == G_ARRAY) {
2543             EXTEND_MORTAL(SP - newsp);
2544             for (mark = newsp + 1; mark <= SP; mark++) {
2545                 if (*mark != &PL_sv_undef
2546                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2547                     /* Might be flattened array after $#array =  */
2548                     PUTBACK;
2549                     LEAVE;
2550                     cxstack_ix--;
2551                     POPSUB(cx,sv);
2552                     PL_curpm = newpm;
2553                     LEAVESUB(sv);
2554                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2555                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2556                 }
2557                 else {
2558                     /* Can be a localized value subject to deletion. */
2559                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2560                     SvREFCNT_inc_void(*mark);
2561                 }
2562             }
2563         }
2564     }
2565     else {
2566         if (gimme == G_SCALAR) {
2567           temporise:
2568             MARK = newsp + 1;
2569             if (MARK <= SP) {
2570                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2571                     if (SvTEMP(TOPs)) {
2572                         *MARK = SvREFCNT_inc(TOPs);
2573                         FREETMPS;
2574                         sv_2mortal(*MARK);
2575                     }
2576                     else {
2577                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2578                         FREETMPS;
2579                         *MARK = sv_mortalcopy(sv);
2580                         SvREFCNT_dec(sv);
2581                     }
2582                 }
2583                 else
2584                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2585             }
2586             else {
2587                 MEXTEND(MARK, 0);
2588                 *MARK = &PL_sv_undef;
2589             }
2590             SP = MARK;
2591         }
2592         else if (gimme == G_ARRAY) {
2593           temporise_array:
2594             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2595                 if (!SvTEMP(*MARK)) {
2596                     *MARK = sv_mortalcopy(*MARK);
2597                     TAINT_NOT;  /* Each item is independent */
2598                 }
2599             }
2600         }
2601     }
2602     PUTBACK;
2603
2604     LEAVE;
2605     cxstack_ix--;
2606     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2607     PL_curpm = newpm;   /* ... and pop $1 et al */
2608
2609     LEAVESUB(sv);
2610     return cx->blk_sub.retop;
2611 }
2612
2613 PP(pp_entersub)
2614 {
2615     dVAR; dSP; dPOPss;
2616     GV *gv;
2617     register CV *cv;
2618     register PERL_CONTEXT *cx;
2619     I32 gimme;
2620     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2621
2622     if (!sv)
2623         DIE(aTHX_ "Not a CODE reference");
2624     switch (SvTYPE(sv)) {
2625         /* This is overwhelming the most common case:  */
2626     case SVt_PVGV:
2627         if (!(cv = GvCVu((GV*)sv))) {
2628             HV *stash;
2629             cv = sv_2cv(sv, &stash, &gv, 0);
2630         }
2631         if (!cv) {
2632             ENTER;
2633             SAVETMPS;
2634             goto try_autoload;
2635         }
2636         break;
2637     default:
2638         if (!SvROK(sv)) {
2639             const char *sym;
2640             STRLEN len;
2641             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2642                 if (hasargs)
2643                     SP = PL_stack_base + POPMARK;
2644                 RETURN;
2645             }
2646             if (SvGMAGICAL(sv)) {
2647                 mg_get(sv);
2648                 if (SvROK(sv))
2649                     goto got_rv;
2650                 if (SvPOKp(sv)) {
2651                     sym = SvPVX_const(sv);
2652                     len = SvCUR(sv);
2653                 } else {
2654                     sym = NULL;
2655                     len = 0;
2656                 }
2657             }
2658             else {
2659                 sym = SvPV_const(sv, len);
2660             }
2661             if (!sym)
2662                 DIE(aTHX_ PL_no_usym, "a subroutine");
2663             if (PL_op->op_private & HINT_STRICT_REFS)
2664                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2665             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2666             break;
2667         }
2668   got_rv:
2669         {
2670             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2671             tryAMAGICunDEREF(to_cv);
2672         }
2673         cv = (CV*)SvRV(sv);
2674         if (SvTYPE(cv) == SVt_PVCV)
2675             break;
2676         /* FALL THROUGH */
2677     case SVt_PVHV:
2678     case SVt_PVAV:
2679         DIE(aTHX_ "Not a CODE reference");
2680         /* This is the second most common case:  */
2681     case SVt_PVCV:
2682         cv = (CV*)sv;
2683         break;
2684     }
2685
2686     ENTER;
2687     SAVETMPS;
2688
2689   retry:
2690     if (!CvROOT(cv) && !CvXSUB(cv)) {
2691         GV* autogv;
2692         SV* sub_name;
2693
2694         /* anonymous or undef'd function leaves us no recourse */
2695         if (CvANON(cv) || !(gv = CvGV(cv)))
2696             DIE(aTHX_ "Undefined subroutine called");
2697
2698         /* autoloaded stub? */
2699         if (cv != GvCV(gv)) {
2700             cv = GvCV(gv);
2701         }
2702         /* should call AUTOLOAD now? */
2703         else {
2704 try_autoload:
2705             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2706                                    FALSE)))
2707             {
2708                 cv = GvCV(autogv);
2709             }
2710             /* sorry */
2711             else {
2712                 sub_name = sv_newmortal();
2713                 gv_efullname3(sub_name, gv, NULL);
2714                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2715             }
2716         }
2717         if (!cv)
2718             DIE(aTHX_ "Not a CODE reference");
2719         goto retry;
2720     }
2721
2722     gimme = GIMME_V;
2723     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2724         if (CvASSERTION(cv) && PL_DBassertion)
2725             sv_setiv(PL_DBassertion, 1);
2726
2727          Perl_get_db_sub(aTHX_ &sv, cv);
2728          if (CvISXSUB(cv))
2729              PL_curcopdb = PL_curcop;
2730          cv = GvCV(PL_DBsub);
2731
2732         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2733             DIE(aTHX_ "No DB::sub routine defined");
2734     }
2735
2736     if (!(CvISXSUB(cv))) {
2737         /* This path taken at least 75% of the time   */
2738         dMARK;
2739         register I32 items = SP - MARK;
2740         AV* const padlist = CvPADLIST(cv);
2741         PUSHBLOCK(cx, CXt_SUB, MARK);
2742         PUSHSUB(cx);
2743         cx->blk_sub.retop = PL_op->op_next;
2744         CvDEPTH(cv)++;
2745         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2746          * that eval'' ops within this sub know the correct lexical space.
2747          * Owing the speed considerations, we choose instead to search for
2748          * the cv using find_runcv() when calling doeval().
2749          */
2750         if (CvDEPTH(cv) >= 2) {
2751             PERL_STACK_OVERFLOW_CHECK();
2752             pad_push(padlist, CvDEPTH(cv));
2753         }
2754         SAVECOMPPAD();
2755         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2756         if (hasargs) {
2757             AV* const av = (AV*)PAD_SVl(0);
2758             if (AvREAL(av)) {
2759                 /* @_ is normally not REAL--this should only ever
2760                  * happen when DB::sub() calls things that modify @_ */
2761                 av_clear(av);
2762                 AvREAL_off(av);
2763                 AvREIFY_on(av);
2764             }
2765             cx->blk_sub.savearray = GvAV(PL_defgv);
2766             GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2767             CX_CURPAD_SAVE(cx->blk_sub);
2768             cx->blk_sub.argarray = av;
2769             ++MARK;
2770
2771             if (items > AvMAX(av) + 1) {
2772                 SV **ary = AvALLOC(av);
2773                 if (AvARRAY(av) != ary) {
2774                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2775                     AvARRAY(av) = ary;
2776                 }
2777                 if (items > AvMAX(av) + 1) {
2778                     AvMAX(av) = items - 1;
2779                     Renew(ary,items,SV*);
2780                     AvALLOC(av) = ary;
2781                     AvARRAY(av) = ary;
2782                 }
2783             }
2784             Copy(MARK,AvARRAY(av),items,SV*);
2785             AvFILLp(av) = items - 1;
2786
2787             while (items--) {
2788                 if (*MARK)
2789                     SvTEMP_off(*MARK);
2790                 MARK++;
2791             }
2792         }
2793         /* warning must come *after* we fully set up the context
2794          * stuff so that __WARN__ handlers can safely dounwind()
2795          * if they want to
2796          */
2797         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2798             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2799             sub_crush_depth(cv);
2800 #if 0
2801         DEBUG_S(PerlIO_printf(Perl_debug_log,
2802                               "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2803 #endif
2804         RETURNOP(CvSTART(cv));
2805     }
2806     else {
2807         I32 markix = TOPMARK;
2808
2809         PUTBACK;
2810
2811         if (!hasargs) {
2812             /* Need to copy @_ to stack. Alternative may be to
2813              * switch stack to @_, and copy return values
2814              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2815             AV * const av = GvAV(PL_defgv);
2816             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2817
2818             if (items) {
2819                 /* Mark is at the end of the stack. */
2820                 EXTEND(SP, items);
2821                 Copy(AvARRAY(av), SP + 1, items, SV*);
2822                 SP += items;
2823                 PUTBACK ;
2824             }
2825         }
2826         /* We assume first XSUB in &DB::sub is the called one. */
2827         if (PL_curcopdb) {
2828             SAVEVPTR(PL_curcop);
2829             PL_curcop = PL_curcopdb;
2830             PL_curcopdb = NULL;
2831         }
2832         /* Do we need to open block here? XXXX */
2833         if (CvXSUB(cv)) /* XXX this is supposed to be true */
2834             (void)(*CvXSUB(cv))(aTHX_ cv);
2835
2836         /* Enforce some sanity in scalar context. */
2837         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2838             if (markix > PL_stack_sp - PL_stack_base)
2839                 *(PL_stack_base + markix) = &PL_sv_undef;
2840             else
2841                 *(PL_stack_base + markix) = *PL_stack_sp;
2842             PL_stack_sp = PL_stack_base + markix;
2843         }
2844         LEAVE;
2845         return NORMAL;
2846     }
2847 }
2848
2849 void
2850 Perl_sub_crush_depth(pTHX_ CV *cv)
2851 {
2852     if (CvANON(cv))
2853         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2854     else {
2855         SV* const tmpstr = sv_newmortal();
2856         gv_efullname3(tmpstr, CvGV(cv), NULL);
2857         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2858                     SVfARG(tmpstr));
2859     }
2860 }
2861
2862 PP(pp_aelem)
2863 {
2864     dVAR; dSP;
2865     SV** svp;
2866     SV* const elemsv = POPs;
2867     IV elem = SvIV(elemsv);
2868     AV* const av = (AV*)POPs;
2869     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2870     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2871     SV *sv;
2872
2873     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2874         Perl_warner(aTHX_ packWARN(WARN_MISC),
2875                     "Use of reference \"%"SVf"\" as array index",
2876                     SVfARG(elemsv));
2877     if (elem > 0)
2878         elem -= CopARYBASE_get(PL_curcop);
2879     if (SvTYPE(av) != SVt_PVAV)
2880         RETPUSHUNDEF;
2881     svp = av_fetch(av, elem, lval && !defer);
2882     if (lval) {
2883 #ifdef PERL_MALLOC_WRAP
2884          if (SvUOK(elemsv)) {
2885               const UV uv = SvUV(elemsv);
2886               elem = uv > IV_MAX ? IV_MAX : uv;
2887          }
2888          else if (SvNOK(elemsv))
2889               elem = (IV)SvNV(elemsv);
2890          if (elem > 0) {
2891               static const char oom_array_extend[] =
2892                 "Out of memory during array extend"; /* Duplicated in av.c */
2893               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2894          }
2895 #endif
2896         if (!svp || *svp == &PL_sv_undef) {
2897             SV* lv;
2898             if (!defer)
2899                 DIE(aTHX_ PL_no_aelem, elem);
2900             lv = sv_newmortal();
2901             sv_upgrade(lv, SVt_PVLV);
2902             LvTYPE(lv) = 'y';
2903             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2904             LvTARG(lv) = SvREFCNT_inc_simple(av);
2905             LvTARGOFF(lv) = elem;
2906             LvTARGLEN(lv) = 1;
2907             PUSHs(lv);
2908             RETURN;
2909         }
2910         if (PL_op->op_private & OPpLVAL_INTRO)
2911             save_aelem(av, elem, svp);
2912         else if (PL_op->op_private & OPpDEREF)
2913             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2914     }
2915     sv = (svp ? *svp : &PL_sv_undef);
2916     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2917         sv = sv_mortalcopy(sv);
2918     PUSHs(sv);
2919     RETURN;
2920 }
2921
2922 void
2923 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2924 {
2925     SvGETMAGIC(sv);
2926     if (!SvOK(sv)) {
2927         if (SvREADONLY(sv))
2928             Perl_croak(aTHX_ PL_no_modify);
2929         if (SvTYPE(sv) < SVt_RV)
2930             sv_upgrade(sv, SVt_RV);
2931         else if (SvTYPE(sv) >= SVt_PV) {
2932             SvPV_free(sv);
2933             SvLEN_set(sv, 0);
2934             SvCUR_set(sv, 0);
2935         }
2936         switch (to_what) {
2937         case OPpDEREF_SV:
2938             SvRV_set(sv, newSV(0));
2939             break;
2940         case OPpDEREF_AV:
2941             SvRV_set(sv, (SV*)newAV());
2942             break;
2943         case OPpDEREF_HV:
2944             SvRV_set(sv, (SV*)newHV());
2945             break;
2946         }
2947         SvROK_on(sv);
2948         SvSETMAGIC(sv);
2949     }
2950 }
2951
2952 PP(pp_method)
2953 {
2954     dVAR; dSP;
2955     SV* const sv = TOPs;
2956
2957     if (SvROK(sv)) {
2958         SV* const rsv = SvRV(sv);
2959         if (SvTYPE(rsv) == SVt_PVCV) {
2960             SETs(rsv);
2961             RETURN;
2962         }
2963     }
2964
2965     SETs(method_common(sv, NULL));
2966     RETURN;
2967 }
2968
2969 PP(pp_method_named)
2970 {
2971     dVAR; dSP;
2972     SV* const sv = cSVOP_sv;
2973     U32 hash = SvSHARED_HASH(sv);
2974
2975     XPUSHs(method_common(sv, &hash));
2976     RETURN;
2977 }
2978
2979 STATIC SV *
2980 S_method_common(pTHX_ SV* meth, U32* hashp)
2981 {
2982     dVAR;
2983     SV* ob;
2984     GV* gv;
2985     HV* stash;
2986     STRLEN namelen;
2987     const char* packname = NULL;
2988     SV *packsv = NULL;
2989     STRLEN packlen;
2990     const char * const name = SvPV_const(meth, namelen);
2991     SV * const sv = *(PL_stack_base + TOPMARK + 1);
2992
2993     if (!sv)
2994         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2995
2996     SvGETMAGIC(sv);
2997     if (SvROK(sv))
2998         ob = (SV*)SvRV(sv);
2999     else {
3000         GV* iogv;
3001
3002         /* this isn't a reference */
3003         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3004           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3005           if (he) {
3006             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3007             goto fetch;
3008           }
3009         }
3010
3011         if (!SvOK(sv) ||
3012             !(packname) ||
3013             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3014             !(ob=(SV*)GvIO(iogv)))
3015         {
3016             /* this isn't the name of a filehandle either */
3017             if (!packname ||
3018                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3019                     ? !isIDFIRST_utf8((U8*)packname)
3020                     : !isIDFIRST(*packname)
3021                 ))
3022             {
3023                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3024                            SvOK(sv) ? "without a package or object reference"
3025                                     : "on an undefined value");
3026             }
3027             /* assume it's a package name */
3028             stash = gv_stashpvn(packname, packlen, 0);
3029             if (!stash)
3030                 packsv = sv;
3031             else {
3032                 SV* const ref = newSViv(PTR2IV(stash));
3033                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3034             }
3035             goto fetch;
3036         }
3037         /* it _is_ a filehandle name -- replace with a reference */
3038         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3039     }
3040
3041     /* if we got here, ob should be a reference or a glob */
3042     if (!ob || !(SvOBJECT(ob)
3043                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3044                      && SvOBJECT(ob))))
3045     {
3046         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3047                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3048                    name);
3049     }
3050
3051     stash = SvSTASH(ob);
3052
3053   fetch:
3054     /* NOTE: stash may be null, hope hv_fetch_ent and
3055        gv_fetchmethod can cope (it seems they can) */
3056
3057     /* shortcut for simple names */
3058     if (hashp) {
3059         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3060         if (he) {
3061             gv = (GV*)HeVAL(he);
3062             if (isGV(gv) && GvCV(gv) &&
3063                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3064                 return (SV*)GvCV(gv);
3065         }
3066     }
3067
3068     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3069
3070     if (!gv) {
3071         /* This code tries to figure out just what went wrong with
3072            gv_fetchmethod.  It therefore needs to duplicate a lot of
3073            the internals of that function.  We can't move it inside
3074            Perl_gv_fetchmethod_autoload(), however, since that would
3075            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3076            don't want that.
3077         */
3078         const char* leaf = name;
3079         const char* sep = NULL;
3080         const char* p;
3081
3082         for (p = name; *p; p++) {
3083             if (*p == '\'')
3084                 sep = p, leaf = p + 1;
3085             else if (*p == ':' && *(p + 1) == ':')
3086                 sep = p, leaf = p + 2;
3087         }
3088         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3089             /* the method name is unqualified or starts with SUPER:: */
3090             bool need_strlen = 1;
3091             if (sep) {
3092                 packname = CopSTASHPV(PL_curcop);
3093             }
3094             else if (stash) {
3095                 HEK * const packhek = HvNAME_HEK(stash);
3096                 if (packhek) {
3097                     packname = HEK_KEY(packhek);
3098                     packlen = HEK_LEN(packhek);
3099                     need_strlen = 0;
3100                 } else {
3101                     goto croak;
3102                 }
3103             }
3104
3105             if (!packname) {
3106             croak:
3107                 Perl_croak(aTHX_
3108                            "Can't use anonymous symbol table for method lookup");
3109             }
3110             else if (need_strlen)
3111                 packlen = strlen(packname);
3112
3113         }
3114         else {
3115             /* the method name is qualified */
3116             packname = name;
3117             packlen = sep - name;
3118         }
3119
3120         /* we're relying on gv_fetchmethod not autovivifying the stash */
3121         if (gv_stashpvn(packname, packlen, 0)) {
3122             Perl_croak(aTHX_
3123                        "Can't locate object method \"%s\" via package \"%.*s\"",
3124                        leaf, (int)packlen, packname);
3125         }
3126         else {
3127             Perl_croak(aTHX_
3128                        "Can't locate object method \"%s\" via package \"%.*s\""
3129                        " (perhaps you forgot to load \"%.*s\"?)",
3130                        leaf, (int)packlen, packname, (int)packlen, packname);
3131         }
3132     }
3133     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3134 }
3135
3136 /*
3137  * Local variables:
3138  * c-indentation-style: bsd
3139  * c-basic-offset: 4
3140  * indent-tabs-mode: t
3141  * End:
3142  *
3143  * ex: set ts=8 sts=4 sw=4 noet:
3144  */