pp_hot.c

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