pp.c

   1 /*    pp.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  * 'It's a big house this, and very peculiar.  Always a bit more
  13  *  to discover, and no knowing what you'll find round a corner.
  14  *  And Elves, sir!'                            --Samwise Gamgee
  15  *
  16  *     [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
  17  */
  18
  19 /* This file contains general pp ("push/pop") functions that execute the
  20  * opcodes that make up a perl program. A typical pp function expects to
  21  * find its arguments on the stack, and usually pushes its results onto
  22  * the stack, hence the 'pp' terminology. Each OP structure contains
  23  * a pointer to the relevant pp_foo() function.
  24  */
  25
  26 #include "EXTERN.h"
  27 #define PERL_IN_PP_C
  28 #include "perl.h"
  29 #include "keywords.h"
  30
  31 #include "reentr.h"
  32 #include "regcharclass.h"
  33
  34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
  35    it, since pid_t is an integral type.
  36    --AD  2/20/1998
  37 */
  38 #ifdef NEED_GETPID_PROTO
  39 extern Pid_t getpid (void);
  40 #endif
  41
  42 /*
  43  * Some BSDs and Cygwin default to POSIX math instead of IEEE.
  44  * This switches them over to IEEE.
  45  */
  46 #if defined(LIBM_LIB_VERSION)
  47     _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
  48 #endif
  49
  50 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
  51 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
  52
  53 /* variations on pp_null */
  54
  55 PP(pp_stub)
  56 {
  57     dSP;
  58     if (GIMME_V == G_SCALAR)
  59         XPUSHs(&PL_sv_undef);
  60     RETURN;
  61 }
  62
  63 /* Pushy stuff. */
  64
  65 /* This is also called directly by pp_lvavref.  */
  66 PP(pp_padav)
  67 {
  68     dSP; dTARGET;
  69     U8 gimme;
  70     assert(SvTYPE(TARG) == SVt_PVAV);
  71     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
  72         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
  73             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
  74     EXTEND(SP, 1);
  75
  76     if (PL_op->op_flags & OPf_REF) {
  77         PUSHs(TARG);
  78         RETURN;
  79     }
  80     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
  81         const I32 flags = is_lvalue_sub();
  82         if (flags && !(flags & OPpENTERSUB_INARGS)) {
  83             if (GIMME_V == G_SCALAR)
  84                 /* diag_listed_as: Can't return %s to lvalue scalar context */
  85                 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
  86             PUSHs(TARG);
  87             RETURN;
  88        }
  89     }
  90
  91     gimme = GIMME_V;
  92     if (gimme == G_ARRAY) {
  93         /* XXX see also S_pushav in pp_hot.c */
  94         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
  95         EXTEND(SP, maxarg);
  96         if (SvMAGICAL(TARG)) {
  97             SSize_t i;
  98             for (i=0; i < maxarg; i++) {
  99                 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
 100                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
 101             }
 102         }
 103         else {
 104             SSize_t i;
 105             for (i=0; i < maxarg; i++) {
 106                 SV * const sv = AvARRAY((const AV *)TARG)[i];
 107                 SP[i+1] = sv ? sv : &PL_sv_undef;
 108             }
 109         }
 110         SP += maxarg;
 111     }
 112     else if (gimme == G_SCALAR) {
 113         SV* const sv = sv_newmortal();
 114         const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
 115         sv_setiv(sv, maxarg);
 116         PUSHs(sv);
 117     }
 118     RETURN;
 119 }
 120
 121 PP(pp_padhv)
 122 {
 123     dSP; dTARGET;
 124     U8 gimme;
 125
 126     assert(SvTYPE(TARG) == SVt_PVHV);
 127     XPUSHs(TARG);
 128     if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
 129         if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
 130             SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 131
 132     if (PL_op->op_flags & OPf_REF)
 133         RETURN;
 134     else if (PL_op->op_private & OPpMAYBE_LVSUB) {
 135         const I32 flags = is_lvalue_sub();
 136         if (flags && !(flags & OPpENTERSUB_INARGS)) {
 137             if (GIMME_V == G_SCALAR)
 138                 /* diag_listed_as: Can't return %s to lvalue scalar context */
 139                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 140             RETURN;
 141         }
 142     }
 143
 144     gimme = GIMME_V;
 145     if (gimme == G_ARRAY) {
 146         RETURNOP(Perl_do_kv(aTHX));
 147     }
 148     else if ((PL_op->op_private & OPpTRUEBOOL
 149           || (  PL_op->op_private & OPpMAYBE_TRUEBOOL
 150              && block_gimme() == G_VOID  ))
 151           && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))
 152     )
 153         SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : &PL_sv_no);
 154     else if (gimme == G_SCALAR) {
 155         SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
 156         SETs(sv);
 157     }
 158     RETURN;
 159 }
 160
 161 PP(pp_padcv)
 162 {
 163     dSP; dTARGET;
 164     assert(SvTYPE(TARG) == SVt_PVCV);
 165     XPUSHs(TARG);
 166     RETURN;
 167 }
 168
 169 PP(pp_introcv)
 170 {
 171     dTARGET;
 172     SvPADSTALE_off(TARG);
 173     return NORMAL;
 174 }
 175
 176 PP(pp_clonecv)
 177 {
 178     dTARGET;
 179     CV * const protocv = PadnamePROTOCV(
 180         PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
 181     );
 182     assert(SvTYPE(TARG) == SVt_PVCV);
 183     assert(protocv);
 184     if (CvISXSUB(protocv)) { /* constant */
 185         /* XXX Should we clone it here? */
 186         /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
 187            to introcv and remove the SvPADSTALE_off. */
 188         SAVEPADSVANDMORTALIZE(ARGTARG);
 189         PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
 190     }
 191     else {
 192         if (CvROOT(protocv)) {
 193             assert(CvCLONE(protocv));
 194             assert(!CvCLONED(protocv));
 195         }
 196         cv_clone_into(protocv,(CV *)TARG);
 197         SAVECLEARSV(PAD_SVl(ARGTARG));
 198     }
 199     return NORMAL;
 200 }
 201
 202 /* Translations. */
 203
 204 /* In some cases this function inspects PL_op.  If this function is called
 205    for new op types, more bool parameters may need to be added in place of
 206    the checks.
 207
 208    When noinit is true, the absence of a gv will cause a retval of undef.
 209    This is unrelated to the cv-to-gv assignment case.
 210 */
 211
 212 static SV *
 213 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
 214               const bool noinit)
 215 {
 216     if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
 217     if (SvROK(sv)) {
 218         if (SvAMAGIC(sv)) {
 219             sv = amagic_deref_call(sv, to_gv_amg);
 220         }
 221       wasref:
 222         sv = SvRV(sv);
 223         if (SvTYPE(sv) == SVt_PVIO) {
 224             GV * const gv = MUTABLE_GV(sv_newmortal());
 225             gv_init(gv, 0, "__ANONIO__", 10, 0);
 226             GvIOp(gv) = MUTABLE_IO(sv);
 227             SvREFCNT_inc_void_NN(sv);
 228             sv = MUTABLE_SV(gv);
 229         }
 230         else if (!isGV_with_GP(sv)) {
 231             Perl_die(aTHX_ "Not a GLOB reference");
 232         }
 233     }
 234     else {
 235         if (!isGV_with_GP(sv)) {
 236             if (!SvOK(sv)) {
 237                 /* If this is a 'my' scalar and flag is set then vivify
 238                  * NI-S 1999/05/07
 239                  */
 240                 if (vivify_sv && sv != &PL_sv_undef) {
 241                     GV *gv;
 242                     if (SvREADONLY(sv))
 243                         Perl_croak_no_modify();
 244                     if (cUNOP->op_targ) {
 245                         SV * const namesv = PAD_SV(cUNOP->op_targ);
 246                         HV *stash = CopSTASH(PL_curcop);
 247                         if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
 248                         gv = MUTABLE_GV(newSV(0));
 249                         gv_init_sv(gv, stash, namesv, 0);
 250                     }
 251                     else {
 252                         const char * const name = CopSTASHPV(PL_curcop);
 253                         gv = newGVgen_flags(name,
 254                                 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
 255                         SvREFCNT_inc_simple_void_NN(gv);
 256                     }
 257                     prepare_SV_for_RV(sv);
 258                     SvRV_set(sv, MUTABLE_SV(gv));
 259                     SvROK_on(sv);
 260                     SvSETMAGIC(sv);
 261                     goto wasref;
 262                 }
 263                 if (PL_op->op_flags & OPf_REF || strict) {
 264                     Perl_die(aTHX_ PL_no_usym, "a symbol");
 265                 }
 266                 if (ckWARN(WARN_UNINITIALIZED))
 267                     report_uninit(sv);
 268                 return &PL_sv_undef;
 269             }
 270             if (noinit)
 271             {
 272                 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
 273                            sv, GV_ADDMG, SVt_PVGV
 274                    ))))
 275                     return &PL_sv_undef;
 276             }
 277             else {
 278                 if (strict) {
 279                     Perl_die(aTHX_
 280                              PL_no_symref_sv,
 281                              sv,
 282                              (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
 283                              "a symbol"
 284                              );
 285                 }
 286                 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
 287                     == OPpDONT_INIT_GV) {
 288                     /* We are the target of a coderef assignment.  Return
 289                        the scalar unchanged, and let pp_sasssign deal with
 290                        things.  */
 291                     return sv;
 292                 }
 293                 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
 294             }
 295             /* FAKE globs in the symbol table cause weird bugs (#77810) */
 296             SvFAKE_off(sv);
 297         }
 298     }
 299     if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
 300         SV *newsv = sv_newmortal();
 301         sv_setsv_flags(newsv, sv, 0);
 302         SvFAKE_off(newsv);
 303         sv = newsv;
 304     }
 305     return sv;
 306 }
 307
 308 PP(pp_rv2gv)
 309 {
 310     dSP; dTOPss;
 311
 312     sv = S_rv2gv(aTHX_
 313           sv, PL_op->op_private & OPpDEREF,
 314           PL_op->op_private & HINT_STRICT_REFS,
 315           ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
 316              || PL_op->op_type == OP_READLINE
 317          );
 318     if (PL_op->op_private & OPpLVAL_INTRO)
 319         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
 320     SETs(sv);
 321     RETURN;
 322 }
 323
 324 /* Helper function for pp_rv2sv and pp_rv2av  */
 325 GV *
 326 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
 327                 const svtype type, SV ***spp)
 328 {
 329     GV *gv;
 330
 331     PERL_ARGS_ASSERT_SOFTREF2XV;
 332
 333     if (PL_op->op_private & HINT_STRICT_REFS) {
 334         if (SvOK(sv))
 335             Perl_die(aTHX_ PL_no_symref_sv, sv,
 336                      (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
 337         else
 338             Perl_die(aTHX_ PL_no_usym, what);
 339     }
 340     if (!SvOK(sv)) {
 341         if (
 342           PL_op->op_flags & OPf_REF
 343         )
 344             Perl_die(aTHX_ PL_no_usym, what);
 345         if (ckWARN(WARN_UNINITIALIZED))
 346             report_uninit(sv);
 347         if (type != SVt_PV && GIMME_V == G_ARRAY) {
 348             (*spp)--;
 349             return NULL;
 350         }
 351         **spp = &PL_sv_undef;
 352         return NULL;
 353     }
 354     if ((PL_op->op_flags & OPf_SPECIAL) &&
 355         !(PL_op->op_flags & OPf_MOD))
 356         {
 357             if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
 358                 {
 359                     **spp = &PL_sv_undef;
 360                     return NULL;
 361                 }
 362         }
 363     else {
 364         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
 365     }
 366     return gv;
 367 }
 368
 369 PP(pp_rv2sv)
 370 {
 371     dSP; dTOPss;
 372     GV *gv = NULL;
 373
 374     SvGETMAGIC(sv);
 375     if (SvROK(sv)) {
 376         if (SvAMAGIC(sv)) {
 377             sv = amagic_deref_call(sv, to_sv_amg);
 378         }
 379
 380         sv = SvRV(sv);
 381         if (SvTYPE(sv) >= SVt_PVAV)
 382             DIE(aTHX_ "Not a SCALAR reference");
 383     }
 384     else {
 385         gv = MUTABLE_GV(sv);
 386
 387         if (!isGV_with_GP(gv)) {
 388             gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
 389             if (!gv)
 390                 RETURN;
 391         }
 392         sv = GvSVn(gv);
 393     }
 394     if (PL_op->op_flags & OPf_MOD) {
 395         if (PL_op->op_private & OPpLVAL_INTRO) {
 396             if (cUNOP->op_first->op_type == OP_NULL)
 397                 sv = save_scalar(MUTABLE_GV(TOPs));
 398             else if (gv)
 399                 sv = save_scalar(gv);
 400             else
 401                 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
 402         }
 403         else if (PL_op->op_private & OPpDEREF)
 404             sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
 405     }
 406     SPAGAIN; /* in case chasing soft refs reallocated the stack */
 407     SETs(sv);
 408     RETURN;
 409 }
 410
 411 PP(pp_av2arylen)
 412 {
 413     dSP;
 414     AV * const av = MUTABLE_AV(TOPs);
 415     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 416     if (lvalue) {
 417         SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
 418         if (!*svp) {
 419             *svp = newSV_type(SVt_PVMG);
 420             sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
 421         }
 422         SETs(*svp);
 423     } else {
 424         SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
 425     }
 426     RETURN;
 427 }
 428
 429 PP(pp_pos)
 430 {
 431     dSP; dTOPss;
 432
 433     if (PL_op->op_flags & OPf_MOD || LVRET) {
 434         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
 435         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
 436         LvTYPE(ret) = '.';
 437         LvTARG(ret) = SvREFCNT_inc_simple(sv);
 438         SETs(ret);    /* no SvSETMAGIC */
 439     }
 440     else {
 441             const MAGIC * const mg = mg_find_mglob(sv);
 442             if (mg && mg->mg_len != -1) {
 443                 dTARGET;
 444                 STRLEN i = mg->mg_len;
 445                 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
 446                     i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
 447                 SETu(i);
 448                 return NORMAL;
 449             }
 450             SETs(&PL_sv_undef);
 451     }
 452     return NORMAL;
 453 }
 454
 455 PP(pp_rv2cv)
 456 {
 457     dSP;
 458     GV *gv;
 459     HV *stash_unused;
 460     const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
 461         ? GV_ADDMG
 462         : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
 463                                                     == OPpMAY_RETURN_CONSTANT)
 464             ? GV_ADD|GV_NOEXPAND
 465             : GV_ADD;
 466     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 467     /* (But not in defined().) */
 468
 469     CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
 470     if (cv) NOOP;
 471     else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
 472         cv = SvTYPE(SvRV(gv)) == SVt_PVCV
 473             ? MUTABLE_CV(SvRV(gv))
 474             : MUTABLE_CV(gv);
 475     }
 476     else
 477         cv = MUTABLE_CV(&PL_sv_undef);
 478     SETs(MUTABLE_SV(cv));
 479     return NORMAL;
 480 }
 481
 482 PP(pp_prototype)
 483 {
 484     dSP;
 485     CV *cv;
 486     HV *stash;
 487     GV *gv;
 488     SV *ret = &PL_sv_undef;
 489
 490     if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
 491     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 492         const char * s = SvPVX_const(TOPs);
 493         if (strnEQ(s, "CORE::", 6)) {
 494             const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
 495             if (!code)
 496                 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
 497                    UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
 498             {
 499                 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
 500                 if (sv) ret = sv;
 501             }
 502             goto set;
 503         }
 504     }
 505     cv = sv_2cv(TOPs, &stash, &gv, 0);
 506     if (cv && SvPOK(cv))
 507         ret = newSVpvn_flags(
 508             CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
 509         );
 510   set:
 511     SETs(ret);
 512     RETURN;
 513 }
 514
 515 PP(pp_anoncode)
 516 {
 517     dSP;
 518     CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
 519     if (CvCLONE(cv))
 520         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
 521     EXTEND(SP,1);
 522     PUSHs(MUTABLE_SV(cv));
 523     RETURN;
 524 }
 525
 526 PP(pp_srefgen)
 527 {
 528     dSP;
 529     *SP = refto(*SP);
 530     return NORMAL;
 531 }
 532
 533 PP(pp_refgen)
 534 {
 535     dSP; dMARK;
 536     if (GIMME_V != G_ARRAY) {
 537         if (++MARK <= SP)
 538             *MARK = *SP;
 539         else
 540         {
 541             MEXTEND(SP, 1);
 542             *MARK = &PL_sv_undef;
 543         }
 544         *MARK = refto(*MARK);
 545         SP = MARK;
 546         RETURN;
 547     }
 548     EXTEND_MORTAL(SP - MARK);
 549     while (++MARK <= SP)
 550         *MARK = refto(*MARK);
 551     RETURN;
 552 }
 553
 554 STATIC SV*
 555 S_refto(pTHX_ SV *sv)
 556 {
 557     SV* rv;
 558
 559     PERL_ARGS_ASSERT_REFTO;
 560
 561     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 562         if (LvTARGLEN(sv))
 563             vivify_defelem(sv);
 564         if (!(sv = LvTARG(sv)))
 565             sv = &PL_sv_undef;
 566         else
 567             SvREFCNT_inc_void_NN(sv);
 568     }
 569     else if (SvTYPE(sv) == SVt_PVAV) {
 570         if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
 571             av_reify(MUTABLE_AV(sv));
 572         SvTEMP_off(sv);
 573         SvREFCNT_inc_void_NN(sv);
 574     }
 575     else if (SvPADTMP(sv)) {
 576         sv = newSVsv(sv);
 577     }
 578     else {
 579         SvTEMP_off(sv);
 580         SvREFCNT_inc_void_NN(sv);
 581     }
 582     rv = sv_newmortal();
 583     sv_upgrade(rv, SVt_IV);
 584     SvRV_set(rv, sv);
 585     SvROK_on(rv);
 586     return rv;
 587 }
 588
 589 PP(pp_ref)
 590 {
 591     dSP;
 592     SV * const sv = TOPs;
 593
 594     SvGETMAGIC(sv);
 595     if (!SvROK(sv)) {
 596         SETs(&PL_sv_no);
 597         return NORMAL;
 598     }
 599
 600     /* op is in boolean context? */
 601     if (   (PL_op->op_private & OPpTRUEBOOL)
 602         || (   (PL_op->op_private & OPpMAYBE_TRUEBOOL)
 603             && block_gimme() == G_VOID))
 604     {
 605         /* refs are always true - unless it's to an object blessed into a
 606          * class with a false name, i.e. "0". So we have to check for
 607          * that remote possibility. The following is is basically an
 608          * unrolled SvTRUE(sv_reftype(rv)) */
 609         SV * const rv = SvRV(sv);
 610         if (SvOBJECT(rv)) {
 611             HV *stash = SvSTASH(rv);
 612             HEK *hek = HvNAME_HEK(stash);
 613             if (hek) {
 614                 I32 len = HEK_LEN(hek);
 615                 /* bail out and do it the hard way? */
 616                 if (UNLIKELY(
 617                        len == HEf_SVKEY
 618                     || (len == 1 && HEK_KEY(hek)[0] == '0')
 619                 ))
 620                     goto do_sv_ref;
 621             }
 622         }
 623         SETs(&PL_sv_yes);
 624         return NORMAL;
 625     }
 626
 627   do_sv_ref:
 628     {
 629         dTARGET;
 630         SETs(TARG);
 631         sv_ref(TARG, SvRV(sv), TRUE);
 632         SvSETMAGIC(TARG);
 633         return NORMAL;
 634     }
 635
 636 }
 637
 638
 639 PP(pp_bless)
 640 {
 641     dSP;
 642     HV *stash;
 643
 644     if (MAXARG == 1)
 645     {
 646       curstash:
 647         stash = CopSTASH(PL_curcop);
 648         if (SvTYPE(stash) != SVt_PVHV)
 649             Perl_croak(aTHX_ "Attempt to bless into a freed package");
 650     }
 651     else {
 652         SV * const ssv = POPs;
 653         STRLEN len;
 654         const char *ptr;
 655
 656         if (!ssv) goto curstash;
 657         SvGETMAGIC(ssv);
 658         if (SvROK(ssv)) {
 659           if (!SvAMAGIC(ssv)) {
 660            frog:
 661             Perl_croak(aTHX_ "Attempt to bless into a reference");
 662           }
 663           /* SvAMAGIC is on here, but it only means potentially overloaded,
 664              so after stringification: */
 665           ptr = SvPV_nomg_const(ssv,len);
 666           /* We need to check the flag again: */
 667           if (!SvAMAGIC(ssv)) goto frog;
 668         }
 669         else ptr = SvPV_nomg_const(ssv,len);
 670         if (len == 0)
 671             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 672                            "Explicit blessing to '' (assuming package main)");
 673         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
 674     }
 675
 676     (void)sv_bless(TOPs, stash);
 677     RETURN;
 678 }
 679
 680 PP(pp_gelem)
 681 {
 682     dSP;
 683
 684     SV *sv = POPs;
 685     STRLEN len;
 686     const char * const elem = SvPV_const(sv, len);
 687     GV * const gv = MUTABLE_GV(TOPs);
 688     SV * tmpRef = NULL;
 689
 690     sv = NULL;
 691     if (elem) {
 692         /* elem will always be NUL terminated.  */
 693         switch (*elem) {
 694         case 'A':
 695             if (memEQs(elem, len, "ARRAY"))
 696             {
 697                 tmpRef = MUTABLE_SV(GvAV(gv));
 698                 if (tmpRef && !AvREAL((const AV *)tmpRef)
 699                  && AvREIFY((const AV *)tmpRef))
 700                     av_reify(MUTABLE_AV(tmpRef));
 701             }
 702             break;
 703         case 'C':
 704             if (memEQs(elem, len, "CODE"))
 705                 tmpRef = MUTABLE_SV(GvCVu(gv));
 706             break;
 707         case 'F':
 708             if (memEQs(elem, len, "FILEHANDLE")) {
 709                 tmpRef = MUTABLE_SV(GvIOp(gv));
 710             }
 711             else
 712                 if (memEQs(elem, len, "FORMAT"))
 713                     tmpRef = MUTABLE_SV(GvFORM(gv));
 714             break;
 715         case 'G':
 716             if (memEQs(elem, len, "GLOB"))
 717                 tmpRef = MUTABLE_SV(gv);
 718             break;
 719         case 'H':
 720             if (memEQs(elem, len, "HASH"))
 721                 tmpRef = MUTABLE_SV(GvHV(gv));
 722             break;
 723         case 'I':
 724             if (memEQs(elem, len, "IO"))
 725                 tmpRef = MUTABLE_SV(GvIOp(gv));
 726             break;
 727         case 'N':
 728             if (memEQs(elem, len, "NAME"))
 729                 sv = newSVhek(GvNAME_HEK(gv));
 730             break;
 731         case 'P':
 732             if (memEQs(elem, len, "PACKAGE")) {
 733                 const HV * const stash = GvSTASH(gv);
 734                 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
 735                 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
 736             }
 737             break;
 738         case 'S':
 739             if (memEQs(elem, len, "SCALAR"))
 740                 tmpRef = GvSVn(gv);
 741             break;
 742         }
 743     }
 744     if (tmpRef)
 745         sv = newRV(tmpRef);
 746     if (sv)
 747         sv_2mortal(sv);
 748     else
 749         sv = &PL_sv_undef;
 750     SETs(sv);
 751     RETURN;
 752 }
 753
 754 /* Pattern matching */
 755
 756 PP(pp_study)
 757 {
 758     dSP; dTOPss;
 759     STRLEN len;
 760
 761     (void)SvPV(sv, len);
 762     if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
 763         /* Historically, study was skipped in these cases. */
 764         SETs(&PL_sv_no);
 765         return NORMAL;
 766     }
 767
 768     /* Make study a no-op. It's no longer useful and its existence
 769        complicates matters elsewhere. */
 770     SETs(&PL_sv_yes);
 771     return NORMAL;
 772 }
 773
 774
 775 /* also used for: pp_transr() */
 776
 777 PP(pp_trans)
 778 {
 779     dSP;
 780     SV *sv;
 781
 782     if (PL_op->op_flags & OPf_STACKED)
 783         sv = POPs;
 784     else {
 785         EXTEND(SP,1);
 786         if (ARGTARG)
 787             sv = PAD_SV(ARGTARG);
 788         else {
 789             sv = DEFSV;
 790         }
 791     }
 792     if(PL_op->op_type == OP_TRANSR) {
 793         STRLEN len;
 794         const char * const pv = SvPV(sv,len);
 795         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
 796         do_trans(newsv);
 797         PUSHs(newsv);
 798     }
 799     else {
 800         I32 i = do_trans(sv);
 801         mPUSHi(i);
 802     }
 803     RETURN;
 804 }
 805
 806 /* Lvalue operators. */
 807
 808 static size_t
 809 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
 810 {
 811     STRLEN len;
 812     char *s;
 813     size_t count = 0;
 814
 815     PERL_ARGS_ASSERT_DO_CHOMP;
 816
 817     if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
 818         return 0;
 819     if (SvTYPE(sv) == SVt_PVAV) {
 820         I32 i;
 821         AV *const av = MUTABLE_AV(sv);
 822         const I32 max = AvFILL(av);
 823
 824         for (i = 0; i <= max; i++) {
 825             sv = MUTABLE_SV(av_fetch(av, i, FALSE));
 826             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 827                 count += do_chomp(retval, sv, chomping);
 828         }
 829         return count;
 830     }
 831     else if (SvTYPE(sv) == SVt_PVHV) {
 832         HV* const hv = MUTABLE_HV(sv);
 833         HE* entry;
 834         (void)hv_iterinit(hv);
 835         while ((entry = hv_iternext(hv)))
 836             count += do_chomp(retval, hv_iterval(hv,entry), chomping);
 837         return count;
 838     }
 839     else if (SvREADONLY(sv)) {
 840             Perl_croak_no_modify();
 841     }
 842
 843     s = SvPV(sv, len);
 844     if (chomping) {
 845         if (s && len) {
 846             char *temp_buffer = NULL;
 847             SV *svrecode = NULL;
 848             s += --len;
 849             if (RsPARA(PL_rs)) {
 850                 if (*s != '\n')
 851                     goto nope_free_nothing;
 852                 ++count;
 853                 while (len && s[-1] == '\n') {
 854                     --len;
 855                     --s;
 856                     ++count;
 857                 }
 858             }
 859             else {
 860                 STRLEN rslen, rs_charlen;
 861                 const char *rsptr = SvPV_const(PL_rs, rslen);
 862
 863                 rs_charlen = SvUTF8(PL_rs)
 864                     ? sv_len_utf8(PL_rs)
 865                     : rslen;
 866
 867                 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
 868                     /* Assumption is that rs is shorter than the scalar.  */
 869                     if (SvUTF8(PL_rs)) {
 870                         /* RS is utf8, scalar is 8 bit.  */
 871                         bool is_utf8 = TRUE;
 872                         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
 873                                                              &rslen, &is_utf8);
 874                         if (is_utf8) {
 875                             /* Cannot downgrade, therefore cannot possibly match.
 876                                At this point, temp_buffer is not alloced, and
 877                                is the buffer inside PL_rs, so dont free it.
 878                              */
 879                             assert (temp_buffer == rsptr);
 880                             goto nope_free_sv;
 881                         }
 882                         rsptr = temp_buffer;
 883                     }
 884                     else {
 885                         /* RS is 8 bit, scalar is utf8.  */
 886                         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
 887                         rsptr = temp_buffer;
 888                     }
 889                 }
 890                 if (rslen == 1) {
 891                     if (*s != *rsptr)
 892                         goto nope_free_all;
 893                     ++count;
 894                 }
 895                 else {
 896                     if (len < rslen - 1)
 897                         goto nope_free_all;
 898                     len -= rslen - 1;
 899                     s -= rslen - 1;
 900                     if (memNE(s, rsptr, rslen))
 901                         goto nope_free_all;
 902                     count += rs_charlen;
 903                 }
 904             }
 905             SvPV_force_nomg_nolen(sv);
 906             SvCUR_set(sv, len);
 907             *SvEND(sv) = '\0';
 908             SvNIOK_off(sv);
 909             SvSETMAGIC(sv);
 910
 911             nope_free_all:
 912             Safefree(temp_buffer);
 913             nope_free_sv:
 914             SvREFCNT_dec(svrecode);
 915             nope_free_nothing: ;
 916         }
 917     } else {
 918         if (len && (!SvPOK(sv) || SvIsCOW(sv)))
 919             s = SvPV_force_nomg(sv, len);
 920         if (DO_UTF8(sv)) {
 921             if (s && len) {
 922                 char * const send = s + len;
 923                 char * const start = s;
 924                 s = send - 1;
 925                 while (s > start && UTF8_IS_CONTINUATION(*s))
 926                     s--;
 927                 if (is_utf8_string((U8*)s, send - s)) {
 928                     sv_setpvn(retval, s, send - s);
 929                     *s = '\0';
 930                     SvCUR_set(sv, s - start);
 931                     SvNIOK_off(sv);
 932                     SvUTF8_on(retval);
 933                 }
 934             }
 935             else
 936                 SvPVCLEAR(retval);
 937         }
 938         else if (s && len) {
 939             s += --len;
 940             sv_setpvn(retval, s, 1);
 941             *s = '\0';
 942             SvCUR_set(sv, len);
 943             SvUTF8_off(sv);
 944             SvNIOK_off(sv);
 945         }
 946         else
 947             SvPVCLEAR(retval);
 948         SvSETMAGIC(sv);
 949     }
 950     return count;
 951 }
 952
 953
 954 /* also used for: pp_schomp() */
 955
 956 PP(pp_schop)
 957 {
 958     dSP; dTARGET;
 959     const bool chomping = PL_op->op_type == OP_SCHOMP;
 960
 961     const size_t count = do_chomp(TARG, TOPs, chomping);
 962     if (chomping)
 963         sv_setiv(TARG, count);
 964     SETTARG;
 965     return NORMAL;
 966 }
 967
 968
 969 /* also used for: pp_chomp() */
 970
 971 PP(pp_chop)
 972 {
 973     dSP; dMARK; dTARGET; dORIGMARK;
 974     const bool chomping = PL_op->op_type == OP_CHOMP;
 975     size_t count = 0;
 976
 977     while (MARK < SP)
 978         count += do_chomp(TARG, *++MARK, chomping);
 979     if (chomping)
 980         sv_setiv(TARG, count);
 981     SP = ORIGMARK;
 982     XPUSHTARG;
 983     RETURN;
 984 }
 985
 986 PP(pp_undef)
 987 {
 988     dSP;
 989     SV *sv;
 990
 991     if (!PL_op->op_private) {
 992         EXTEND(SP, 1);
 993         RETPUSHUNDEF;
 994     }
 995
 996     sv = TOPs;
 997     if (!sv)
 998     {
 999         SETs(&PL_sv_undef);
1000         return NORMAL;
1001     }
1002
1003     if (SvTHINKFIRST(sv))
1004         sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
1005
1006     switch (SvTYPE(sv)) {
1007     case SVt_NULL:
1008         break;
1009     case SVt_PVAV:
1010         av_undef(MUTABLE_AV(sv));
1011         break;
1012     case SVt_PVHV:
1013         hv_undef(MUTABLE_HV(sv));
1014         break;
1015     case SVt_PVCV:
1016         if (cv_const_sv((const CV *)sv))
1017             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1018                           "Constant subroutine %" SVf " undefined",
1019                            SVfARG(CvANON((const CV *)sv)
1020                              ? newSVpvs_flags("(anonymous)", SVs_TEMP)
1021                              : sv_2mortal(newSVhek(
1022                                 CvNAMED(sv)
1023                                  ? CvNAME_HEK((CV *)sv)
1024                                  : GvENAME_HEK(CvGV((const CV *)sv))
1025                                ))
1026                            ));
1027         /* FALLTHROUGH */
1028     case SVt_PVFM:
1029             /* let user-undef'd sub keep its identity */
1030         cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1031         break;
1032     case SVt_PVGV:
1033         assert(isGV_with_GP(sv));
1034         assert(!SvFAKE(sv));
1035         {
1036             GP *gp;
1037             HV *stash;
1038
1039             /* undef *Pkg::meth_name ... */
1040             bool method_changed
1041              =   GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1042               && HvENAME_get(stash);
1043             /* undef *Foo:: */
1044             if((stash = GvHV((const GV *)sv))) {
1045                 if(HvENAME_get(stash))
1046                     SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1047                 else stash = NULL;
1048             }
1049
1050             SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1051             gp_free(MUTABLE_GV(sv));
1052             Newxz(gp, 1, GP);
1053             GvGP_set(sv, gp_ref(gp));
1054 #ifndef PERL_DONT_CREATE_GVSV
1055             GvSV(sv) = newSV(0);
1056 #endif
1057             GvLINE(sv) = CopLINE(PL_curcop);
1058             GvEGV(sv) = MUTABLE_GV(sv);
1059             GvMULTI_on(sv);
1060
1061             if(stash)
1062                 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1063             stash = NULL;
1064             /* undef *Foo::ISA */
1065             if( strEQ(GvNAME((const GV *)sv), "ISA")
1066              && (stash = GvSTASH((const GV *)sv))
1067              && (method_changed || HvENAME(stash)) )
1068                 mro_isa_changed_in(stash);
1069             else if(method_changed)
1070                 mro_method_changed_in(
1071                  GvSTASH((const GV *)sv)
1072                 );
1073
1074             break;
1075         }
1076     default:
1077         if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1078             SvPV_free(sv);
1079             SvPV_set(sv, NULL);
1080             SvLEN_set(sv, 0);
1081         }
1082         SvOK_off(sv);
1083         SvSETMAGIC(sv);
1084     }
1085
1086     SETs(&PL_sv_undef);
1087     return NORMAL;
1088 }
1089
1090
1091 /* common "slow" code for pp_postinc and pp_postdec */
1092
1093 static OP *
1094 S_postincdec_common(pTHX_ SV *sv, SV *targ)
1095 {
1096     dSP;
1097     const bool inc =
1098         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1099
1100     if (SvROK(sv))
1101         TARG = sv_newmortal();
1102     sv_setsv(TARG, sv);
1103     if (inc)
1104         sv_inc_nomg(sv);
1105     else
1106         sv_dec_nomg(sv);
1107     SvSETMAGIC(sv);
1108     /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1109     if (inc && !SvOK(TARG))
1110         sv_setiv(TARG, 0);
1111     SETTARG;
1112     return NORMAL;
1113 }
1114
1115
1116 /* also used for: pp_i_postinc() */
1117
1118 PP(pp_postinc)
1119 {
1120     dSP; dTARGET;
1121     SV *sv = TOPs;
1122
1123     /* special-case sv being a simple integer */
1124     if (LIKELY(((sv->sv_flags &
1125                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1126                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1127                 == SVf_IOK))
1128         && SvIVX(sv) != IV_MAX)
1129     {
1130         IV iv = SvIVX(sv);
1131         SvIV_set(sv,  iv + 1);
1132         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1133         SETs(TARG);
1134         return NORMAL;
1135     }
1136
1137     return S_postincdec_common(aTHX_ sv, TARG);
1138 }
1139
1140
1141 /* also used for: pp_i_postdec() */
1142
1143 PP(pp_postdec)
1144 {
1145     dSP; dTARGET;
1146     SV *sv = TOPs;
1147
1148     /* special-case sv being a simple integer */
1149     if (LIKELY(((sv->sv_flags &
1150                         (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1151                          SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1152                 == SVf_IOK))
1153         && SvIVX(sv) != IV_MIN)
1154     {
1155         IV iv = SvIVX(sv);
1156         SvIV_set(sv,  iv - 1);
1157         TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1158         SETs(TARG);
1159         return NORMAL;
1160     }
1161
1162     return S_postincdec_common(aTHX_ sv, TARG);
1163 }
1164
1165
1166 /* Ordinary operators. */
1167
1168 PP(pp_pow)
1169 {
1170     dSP; dATARGET; SV *svl, *svr;
1171 #ifdef PERL_PRESERVE_IVUV
1172     bool is_int = 0;
1173 #endif
1174     tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1175     svr = TOPs;
1176     svl = TOPm1s;
1177 #ifdef PERL_PRESERVE_IVUV
1178     /* For integer to integer power, we do the calculation by hand wherever
1179        we're sure it is safe; otherwise we call pow() and try to convert to
1180        integer afterwards. */
1181     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1182                 UV power;
1183                 bool baseuok;
1184                 UV baseuv;
1185
1186                 if (SvUOK(svr)) {
1187                     power = SvUVX(svr);
1188                 } else {
1189                     const IV iv = SvIVX(svr);
1190                     if (iv >= 0) {
1191                         power = iv;
1192                     } else {
1193                         goto float_it; /* Can't do negative powers this way.  */
1194                     }
1195                 }
1196
1197                 baseuok = SvUOK(svl);
1198                 if (baseuok) {
1199                     baseuv = SvUVX(svl);
1200                 } else {
1201                     const IV iv = SvIVX(svl);
1202                     if (iv >= 0) {
1203                         baseuv = iv;
1204                         baseuok = TRUE; /* effectively it's a UV now */
1205                     } else {
1206                         baseuv = -iv; /* abs, baseuok == false records sign */
1207                     }
1208                 }
1209                 /* now we have integer ** positive integer. */
1210                 is_int = 1;
1211
1212                 /* foo & (foo - 1) is zero only for a power of 2.  */
1213                 if (!(baseuv & (baseuv - 1))) {
1214                     /* We are raising power-of-2 to a positive integer.
1215                        The logic here will work for any base (even non-integer
1216                        bases) but it can be less accurate than
1217                        pow (base,power) or exp (power * log (base)) when the
1218                        intermediate values start to spill out of the mantissa.
1219                        With powers of 2 we know this can't happen.
1220                        And powers of 2 are the favourite thing for perl
1221                        programmers to notice ** not doing what they mean. */
1222                     NV result = 1.0;
1223                     NV base = baseuok ? baseuv : -(NV)baseuv;
1224
1225                     if (power & 1) {
1226                         result *= base;
1227                     }
1228                     while (power >>= 1) {
1229                         base *= base;
1230                         if (power & 1) {
1231                             result *= base;
1232                         }
1233                     }
1234                     SP--;
1235                     SETn( result );
1236                     SvIV_please_nomg(svr);
1237                     RETURN;
1238                 } else {
1239                     unsigned int highbit = 8 * sizeof(UV);
1240                     unsigned int diff = 8 * sizeof(UV);
1241                     while (diff >>= 1) {
1242                         highbit -= diff;
1243                         if (baseuv >> highbit) {
1244                             highbit += diff;
1245                         }
1246                     }
1247                     /* we now have baseuv < 2 ** highbit */
1248                     if (power * highbit <= 8 * sizeof(UV)) {
1249                         /* result will definitely fit in UV, so use UV math
1250                            on same algorithm as above */
1251                         UV result = 1;
1252                         UV base = baseuv;
1253                         const bool odd_power = cBOOL(power & 1);
1254                         if (odd_power) {
1255                             result *= base;
1256                         }
1257                         while (power >>= 1) {
1258                             base *= base;
1259                             if (power & 1) {
1260                                 result *= base;
1261                             }
1262                         }
1263                         SP--;
1264                         if (baseuok || !odd_power)
1265                             /* answer is positive */
1266                             SETu( result );
1267                         else if (result <= (UV)IV_MAX)
1268                             /* answer negative, fits in IV */
1269                             SETi( -(IV)result );
1270                         else if (result == (UV)IV_MIN)
1271                             /* 2's complement assumption: special case IV_MIN */
1272                             SETi( IV_MIN );
1273                         else
1274                             /* answer negative, doesn't fit */
1275                             SETn( -(NV)result );
1276                         RETURN;
1277                     }
1278                 }
1279     }
1280   float_it:
1281 #endif
1282     {
1283         NV right = SvNV_nomg(svr);
1284         NV left  = SvNV_nomg(svl);
1285         (void)POPs;
1286
1287 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1288     /*
1289     We are building perl with long double support and are on an AIX OS
1290     afflicted with a powl() function that wrongly returns NaNQ for any
1291     negative base.  This was reported to IBM as PMR #23047-379 on
1292     03/06/2006.  The problem exists in at least the following versions
1293     of AIX and the libm fileset, and no doubt others as well:
1294
1295         AIX 4.3.3-ML10      bos.adt.libm 4.3.3.50
1296         AIX 5.1.0-ML04      bos.adt.libm 5.1.0.29
1297         AIX 5.2.0           bos.adt.libm 5.2.0.85
1298
1299     So, until IBM fixes powl(), we provide the following workaround to
1300     handle the problem ourselves.  Our logic is as follows: for
1301     negative bases (left), we use fmod(right, 2) to check if the
1302     exponent is an odd or even integer:
1303
1304         - if odd,  powl(left, right) == -powl(-left, right)
1305         - if even, powl(left, right) ==  powl(-left, right)
1306
1307     If the exponent is not an integer, the result is rightly NaNQ, so
1308     we just return that (as NV_NAN).
1309     */
1310
1311         if (left < 0.0) {
1312             NV mod2 = Perl_fmod( right, 2.0 );
1313             if (mod2 == 1.0 || mod2 == -1.0) {  /* odd integer */
1314                 SETn( -Perl_pow( -left, right) );
1315             } else if (mod2 == 0.0) {           /* even integer */
1316                 SETn( Perl_pow( -left, right) );
1317             } else {                            /* fractional power */
1318                 SETn( NV_NAN );
1319             }
1320         } else {
1321             SETn( Perl_pow( left, right) );
1322         }
1323 #else
1324         SETn( Perl_pow( left, right) );
1325 #endif  /* HAS_AIX_POWL_NEG_BASE_BUG */
1326
1327 #ifdef PERL_PRESERVE_IVUV
1328         if (is_int)
1329             SvIV_please_nomg(svr);
1330 #endif
1331         RETURN;
1332     }
1333 }
1334
1335 PP(pp_multiply)
1336 {
1337     dSP; dATARGET; SV *svl, *svr;
1338     tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1339     svr = TOPs;
1340     svl = TOPm1s;
1341
1342 #ifdef PERL_PRESERVE_IVUV
1343
1344     /* special-case some simple common cases */
1345     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1346         IV il, ir;
1347         U32 flags = (svl->sv_flags & svr->sv_flags);
1348         if (flags & SVf_IOK) {
1349             /* both args are simple IVs */
1350             UV topl, topr;
1351             il = SvIVX(svl);
1352             ir = SvIVX(svr);
1353           do_iv:
1354             topl = ((UV)il) >> (UVSIZE * 4 - 1);
1355             topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1356
1357             /* if both are in a range that can't under/overflow, do a
1358              * simple integer multiply: if the top halves(*) of both numbers
1359              * are 00...00  or 11...11, then it's safe.
1360              * (*) for 32-bits, the "top half" is the top 17 bits,
1361              *     for 64-bits, its 33 bits */
1362             if (!(
1363                       ((topl+1) | (topr+1))
1364                     & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1365             )) {
1366                 SP--;
1367                 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1368                 SETs(TARG);
1369                 RETURN;
1370             }
1371             goto generic;
1372         }
1373         else if (flags & SVf_NOK) {
1374             /* both args are NVs */
1375             NV nl = SvNVX(svl);
1376             NV nr = SvNVX(svr);
1377             NV result;
1378
1379             if (
1380 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1381                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1382                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1383 #else
1384                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1385 #endif
1386                 )
1387                 /* nothing was lost by converting to IVs */
1388                 goto do_iv;
1389             SP--;
1390             result = nl * nr;
1391 #  if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1392             if (Perl_isinf(result)) {
1393                 Zero((U8*)&result + 8, 8, U8);
1394             }
1395 #  endif
1396             TARGn(result, 0); /* args not GMG, so can't be tainted */
1397             SETs(TARG);
1398             RETURN;
1399         }
1400     }
1401
1402   generic:
1403
1404     if (SvIV_please_nomg(svr)) {
1405         /* Unless the left argument is integer in range we are going to have to
1406            use NV maths. Hence only attempt to coerce the right argument if
1407            we know the left is integer.  */
1408         /* Left operand is defined, so is it IV? */
1409         if (SvIV_please_nomg(svl)) {
1410             bool auvok = SvUOK(svl);
1411             bool buvok = SvUOK(svr);
1412             const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1413             const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1414             UV alow;
1415             UV ahigh;
1416             UV blow;
1417             UV bhigh;
1418
1419             if (auvok) {
1420                 alow = SvUVX(svl);
1421             } else {
1422                 const IV aiv = SvIVX(svl);
1423                 if (aiv >= 0) {
1424                     alow = aiv;
1425                     auvok = TRUE; /* effectively it's a UV now */
1426                 } else {
1427                     /* abs, auvok == false records sign */
1428                     alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1429                 }
1430             }
1431             if (buvok) {
1432                 blow = SvUVX(svr);
1433             } else {
1434                 const IV biv = SvIVX(svr);
1435                 if (biv >= 0) {
1436                     blow = biv;
1437                     buvok = TRUE; /* effectively it's a UV now */
1438                 } else {
1439                     /* abs, buvok == false records sign */
1440                     blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1441                 }
1442             }
1443
1444             /* If this does sign extension on unsigned it's time for plan B  */
1445             ahigh = alow >> (4 * sizeof (UV));
1446             alow &= botmask;
1447             bhigh = blow >> (4 * sizeof (UV));
1448             blow &= botmask;
1449             if (ahigh && bhigh) {
1450                 NOOP;
1451                 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1452                    which is overflow. Drop to NVs below.  */
1453             } else if (!ahigh && !bhigh) {
1454                 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1455                    so the unsigned multiply cannot overflow.  */
1456                 const UV product = alow * blow;
1457                 if (auvok == buvok) {
1458                     /* -ve * -ve or +ve * +ve gives a +ve result.  */
1459                     SP--;
1460                     SETu( product );
1461                     RETURN;
1462                 } else if (product <= (UV)IV_MIN) {
1463                     /* 2s complement assumption that (UV)-IV_MIN is correct.  */
1464                     /* -ve result, which could overflow an IV  */
1465                     SP--;
1466                     /* can't negate IV_MIN, but there are aren't two
1467                      * integers such that !ahigh && !bhigh, where the
1468                      * product equals 0x800....000 */
1469                     assert(product != (UV)IV_MIN);
1470                     SETi( -(IV)product );
1471                     RETURN;
1472                 } /* else drop to NVs below. */
1473             } else {
1474                 /* One operand is large, 1 small */
1475                 UV product_middle;
1476                 if (bhigh) {
1477                     /* swap the operands */
1478                     ahigh = bhigh;
1479                     bhigh = blow; /* bhigh now the temp var for the swap */
1480                     blow = alow;
1481                     alow = bhigh;
1482                 }
1483                 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1484                    multiplies can't overflow. shift can, add can, -ve can.  */
1485                 product_middle = ahigh * blow;
1486                 if (!(product_middle & topmask)) {
1487                     /* OK, (ahigh * blow) won't lose bits when we shift it.  */
1488                     UV product_low;
1489                     product_middle <<= (4 * sizeof (UV));
1490                     product_low = alow * blow;
1491
1492                     /* as for pp_add, UV + something mustn't get smaller.
1493                        IIRC ANSI mandates this wrapping *behaviour* for
1494                        unsigned whatever the actual representation*/
1495                     product_low += product_middle;
1496                     if (product_low >= product_middle) {
1497                         /* didn't overflow */
1498                         if (auvok == buvok) {
1499                             /* -ve * -ve or +ve * +ve gives a +ve result.  */
1500                             SP--;
1501                             SETu( product_low );
1502                             RETURN;
1503                         } else if (product_low <= (UV)IV_MIN) {
1504                             /* 2s complement assumption again  */
1505                             /* -ve result, which could overflow an IV  */
1506                             SP--;
1507                             SETi(product_low == (UV)IV_MIN
1508                                     ? IV_MIN : -(IV)product_low);
1509                             RETURN;
1510                         } /* else drop to NVs below. */
1511                     }
1512                 } /* product_middle too large */
1513             } /* ahigh && bhigh */
1514         } /* SvIOK(svl) */
1515     } /* SvIOK(svr) */
1516 #endif
1517     {
1518       NV right = SvNV_nomg(svr);
1519       NV left  = SvNV_nomg(svl);
1520       NV result = left * right;
1521
1522       (void)POPs;
1523 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1524       if (Perl_isinf(result)) {
1525           Zero((U8*)&result + 8, 8, U8);
1526       }
1527 #endif
1528       SETn(result);
1529       RETURN;
1530     }
1531 }
1532
1533 PP(pp_divide)
1534 {
1535     dSP; dATARGET; SV *svl, *svr;
1536     tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1537     svr = TOPs;
1538     svl = TOPm1s;
1539     /* Only try to do UV divide first
1540        if ((SLOPPYDIVIDE is true) or
1541            (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1542             to preserve))
1543        The assumption is that it is better to use floating point divide
1544        whenever possible, only doing integer divide first if we can't be sure.
1545        If NV_PRESERVES_UV is true then we know at compile time that no UV
1546        can be too large to preserve, so don't need to compile the code to
1547        test the size of UVs.  */
1548
1549 #ifdef SLOPPYDIVIDE
1550 #  define PERL_TRY_UV_DIVIDE
1551     /* ensure that 20./5. == 4. */
1552 #else
1553 #  ifdef PERL_PRESERVE_IVUV
1554 #    ifndef NV_PRESERVES_UV
1555 #      define PERL_TRY_UV_DIVIDE
1556 #    endif
1557 #  endif
1558 #endif
1559
1560 #ifdef PERL_TRY_UV_DIVIDE
1561     if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1562             bool left_non_neg = SvUOK(svl);
1563             bool right_non_neg = SvUOK(svr);
1564             UV left;
1565             UV right;
1566
1567             if (right_non_neg) {
1568                 right = SvUVX(svr);
1569             }
1570             else {
1571                 const IV biv = SvIVX(svr);
1572                 if (biv >= 0) {
1573                     right = biv;
1574                     right_non_neg = TRUE; /* effectively it's a UV now */
1575                 }
1576                 else {
1577                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1578                 }
1579             }
1580             /* historically undef()/0 gives a "Use of uninitialized value"
1581                warning before dieing, hence this test goes here.
1582                If it were immediately before the second SvIV_please, then
1583                DIE() would be invoked before left was even inspected, so
1584                no inspection would give no warning.  */
1585             if (right == 0)
1586                 DIE(aTHX_ "Illegal division by zero");
1587
1588             if (left_non_neg) {
1589                 left = SvUVX(svl);
1590             }
1591             else {
1592                 const IV aiv = SvIVX(svl);
1593                 if (aiv >= 0) {
1594                     left = aiv;
1595                     left_non_neg = TRUE; /* effectively it's a UV now */
1596                 }
1597                 else {
1598                     left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1599                 }
1600             }
1601
1602             if (left >= right
1603 #ifdef SLOPPYDIVIDE
1604                 /* For sloppy divide we always attempt integer division.  */
1605 #else
1606                 /* Otherwise we only attempt it if either or both operands
1607                    would not be preserved by an NV.  If both fit in NVs
1608                    we fall through to the NV divide code below.  However,
1609                    as left >= right to ensure integer result here, we know that
1610                    we can skip the test on the right operand - right big
1611                    enough not to be preserved can't get here unless left is
1612                    also too big.  */
1613
1614                 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1615 #endif
1616                 ) {
1617                 /* Integer division can't overflow, but it can be imprecise.  */
1618                 const UV result = left / right;
1619                 if (result * right == left) {
1620                     SP--; /* result is valid */
1621                     if (left_non_neg == right_non_neg) {
1622                         /* signs identical, result is positive.  */
1623                         SETu( result );
1624                         RETURN;
1625                     }
1626                     /* 2s complement assumption */
1627                     if (result <= (UV)IV_MIN)
1628                         SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1629                     else {
1630                         /* It's exact but too negative for IV. */
1631                         SETn( -(NV)result );
1632                     }
1633                     RETURN;
1634                 } /* tried integer divide but it was not an integer result */
1635             } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1636     } /* one operand wasn't SvIOK */
1637 #endif /* PERL_TRY_UV_DIVIDE */
1638     {
1639         NV right = SvNV_nomg(svr);
1640         NV left  = SvNV_nomg(svl);
1641         (void)POPs;(void)POPs;
1642 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1643         if (! Perl_isnan(right) && right == 0.0)
1644 #else
1645         if (right == 0.0)
1646 #endif
1647             DIE(aTHX_ "Illegal division by zero");
1648         PUSHn( left / right );
1649         RETURN;
1650     }
1651 }
1652
1653 PP(pp_modulo)
1654 {
1655     dSP; dATARGET;
1656     tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1657     {
1658         UV left  = 0;
1659         UV right = 0;
1660         bool left_neg = FALSE;
1661         bool right_neg = FALSE;
1662         bool use_double = FALSE;
1663         bool dright_valid = FALSE;
1664         NV dright = 0.0;
1665         NV dleft  = 0.0;
1666         SV * const svr = TOPs;
1667         SV * const svl = TOPm1s;
1668         if (SvIV_please_nomg(svr)) {
1669             right_neg = !SvUOK(svr);
1670             if (!right_neg) {
1671                 right = SvUVX(svr);
1672             } else {
1673                 const IV biv = SvIVX(svr);
1674                 if (biv >= 0) {
1675                     right = biv;
1676                     right_neg = FALSE; /* effectively it's a UV now */
1677                 } else {
1678                     right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
1679                 }
1680             }
1681         }
1682         else {
1683             dright = SvNV_nomg(svr);
1684             right_neg = dright < 0;
1685             if (right_neg)
1686                 dright = -dright;
1687             if (dright < UV_MAX_P1) {
1688                 right = U_V(dright);
1689                 dright_valid = TRUE; /* In case we need to use double below.  */
1690             } else {
1691                 use_double = TRUE;
1692             }
1693         }
1694
1695         /* At this point use_double is only true if right is out of range for
1696            a UV.  In range NV has been rounded down to nearest UV and
1697            use_double false.  */
1698         if (!use_double && SvIV_please_nomg(svl)) {
1699                 left_neg = !SvUOK(svl);
1700                 if (!left_neg) {
1701                     left = SvUVX(svl);
1702                 } else {
1703                     const IV aiv = SvIVX(svl);
1704                     if (aiv >= 0) {
1705                         left = aiv;
1706                         left_neg = FALSE; /* effectively it's a UV now */
1707                     } else {
1708                         left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
1709                     }
1710                 }
1711         }
1712         else {
1713             dleft = SvNV_nomg(svl);
1714             left_neg = dleft < 0;
1715             if (left_neg)
1716                 dleft = -dleft;
1717
1718             /* This should be exactly the 5.6 behaviour - if left and right are
1719                both in range for UV then use U_V() rather than floor.  */
1720             if (!use_double) {
1721                 if (dleft < UV_MAX_P1) {
1722                     /* right was in range, so is dleft, so use UVs not double.
1723                      */
1724                     left = U_V(dleft);
1725                 }
1726                 /* left is out of range for UV, right was in range, so promote
1727                    right (back) to double.  */
1728                 else {
1729                     /* The +0.5 is used in 5.6 even though it is not strictly
1730                        consistent with the implicit +0 floor in the U_V()
1731                        inside the #if 1. */
1732                     dleft = Perl_floor(dleft + 0.5);
1733                     use_double = TRUE;
1734                     if (dright_valid)
1735                         dright = Perl_floor(dright + 0.5);
1736                     else
1737                         dright = right;
1738                 }
1739             }
1740         }
1741         sp -= 2;
1742         if (use_double) {
1743             NV dans;
1744
1745             if (!dright)
1746                 DIE(aTHX_ "Illegal modulus zero");
1747
1748             dans = Perl_fmod(dleft, dright);
1749             if ((left_neg != right_neg) && dans)
1750                 dans = dright - dans;
1751             if (right_neg)
1752                 dans = -dans;
1753             sv_setnv(TARG, dans);
1754         }
1755         else {
1756             UV ans;
1757
1758             if (!right)
1759                 DIE(aTHX_ "Illegal modulus zero");
1760
1761             ans = left % right;
1762             if ((left_neg != right_neg) && ans)
1763                 ans = right - ans;
1764             if (right_neg) {
1765                 /* XXX may warn: unary minus operator applied to unsigned type */
1766                 /* could change -foo to be (~foo)+1 instead     */
1767                 if (ans <= ~((UV)IV_MAX)+1)
1768                     sv_setiv(TARG, ~ans+1);
1769                 else
1770                     sv_setnv(TARG, -(NV)ans);
1771             }
1772             else
1773                 sv_setuv(TARG, ans);
1774         }
1775         PUSHTARG;
1776         RETURN;
1777     }
1778 }
1779
1780 PP(pp_repeat)
1781 {
1782     dSP; dATARGET;
1783     IV count;
1784     SV *sv;
1785     bool infnan = FALSE;
1786
1787     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1788         /* TODO: think of some way of doing list-repeat overloading ??? */
1789         sv = POPs;
1790         SvGETMAGIC(sv);
1791     }
1792     else {
1793         if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1794             /* The parser saw this as a list repeat, and there
1795                are probably several items on the stack. But we're
1796                in scalar/void context, and there's no pp_list to save us
1797                now. So drop the rest of the items -- robin@kitsite.com
1798              */
1799             dMARK;
1800             if (MARK + 1 < SP) {
1801                 MARK[1] = TOPm1s;
1802                 MARK[2] = TOPs;
1803             }
1804             else {
1805                 dTOPss;
1806                 ASSUME(MARK + 1 == SP);
1807                 XPUSHs(sv);
1808                 MARK[1] = &PL_sv_undef;
1809             }
1810             SP = MARK + 2;
1811         }
1812         tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1813         sv = POPs;
1814     }
1815
1816     if (SvIOKp(sv)) {
1817          if (SvUOK(sv)) {
1818               const UV uv = SvUV_nomg(sv);
1819               if (uv > IV_MAX)
1820                    count = IV_MAX; /* The best we can do? */
1821               else
1822                    count = uv;
1823          } else {
1824               count = SvIV_nomg(sv);
1825          }
1826     }
1827     else if (SvNOKp(sv)) {
1828         const NV nv = SvNV_nomg(sv);
1829         infnan = Perl_isinfnan(nv);
1830         if (UNLIKELY(infnan)) {
1831             count = 0;
1832         } else {
1833             if (nv < 0.0)
1834                 count = -1;   /* An arbitrary negative integer */
1835             else
1836                 count = (IV)nv;
1837         }
1838     }
1839     else
1840         count = SvIV_nomg(sv);
1841
1842     if (infnan) {
1843         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1844                        "Non-finite repeat count does nothing");
1845     } else if (count < 0) {
1846         count = 0;
1847         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1848                        "Negative repeat count does nothing");
1849     }
1850
1851     if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1852         dMARK;
1853         const SSize_t items = SP - MARK;
1854         const U8 mod = PL_op->op_flags & OPf_MOD;
1855
1856         if (count > 1) {
1857             SSize_t max;
1858
1859             if (  items > SSize_t_MAX / count   /* max would overflow */
1860                                                 /* repeatcpy would overflow */
1861                || items > I32_MAX / (I32)sizeof(SV *)
1862             )
1863                Perl_croak(aTHX_ "%s","Out of memory during list extend");
1864             max = items * count;
1865             MEXTEND(MARK, max);
1866
1867             while (SP > MARK) {
1868                 if (*SP) {
1869                    if (mod && SvPADTMP(*SP)) {
1870                        *SP = sv_mortalcopy(*SP);
1871                    }
1872                    SvTEMP_off((*SP));
1873                 }
1874                 SP--;
1875             }
1876             MARK++;
1877             repeatcpy((char*)(MARK + items), (char*)MARK,
1878                 items * sizeof(const SV *), count - 1);
1879             SP += max;
1880         }
1881         else if (count <= 0)
1882             SP = MARK;
1883     }
1884     else {      /* Note: mark already snarfed by pp_list */
1885         SV * const tmpstr = POPs;
1886         STRLEN len;
1887         bool isutf;
1888
1889         if (TARG != tmpstr)
1890             sv_setsv_nomg(TARG, tmpstr);
1891         SvPV_force_nomg(TARG, len);
1892         isutf = DO_UTF8(TARG);
1893         if (count != 1) {
1894             if (count < 1)
1895                 SvCUR_set(TARG, 0);
1896             else {
1897                 STRLEN max;
1898
1899                 if (   len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1900                     || len > (U32)I32_MAX  /* repeatcpy would overflow */
1901                 )
1902                      Perl_croak(aTHX_ "%s",
1903                                         "Out of memory during string extend");
1904                 max = (UV)count * len + 1;
1905                 SvGROW(TARG, max);
1906
1907                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1908                 SvCUR_set(TARG, SvCUR(TARG) * count);
1909             }
1910             *SvEND(TARG) = '\0';
1911         }
1912         if (isutf)
1913             (void)SvPOK_only_UTF8(TARG);
1914         else
1915             (void)SvPOK_only(TARG);
1916
1917         PUSHTARG;
1918     }
1919     RETURN;
1920 }
1921
1922 PP(pp_subtract)
1923 {
1924     dSP; dATARGET; bool useleft; SV *svl, *svr;
1925     tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1926     svr = TOPs;
1927     svl = TOPm1s;
1928
1929 #ifdef PERL_PRESERVE_IVUV
1930
1931     /* special-case some simple common cases */
1932     if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1933         IV il, ir;
1934         U32 flags = (svl->sv_flags & svr->sv_flags);
1935         if (flags & SVf_IOK) {
1936             /* both args are simple IVs */
1937             UV topl, topr;
1938             il = SvIVX(svl);
1939             ir = SvIVX(svr);
1940           do_iv:
1941             topl = ((UV)il) >> (UVSIZE * 8 - 2);
1942             topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1943
1944             /* if both are in a range that can't under/overflow, do a
1945              * simple integer subtract: if the top of both numbers
1946              * are 00  or 11, then it's safe */
1947             if (!( ((topl+1) | (topr+1)) & 2)) {
1948                 SP--;
1949                 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1950                 SETs(TARG);
1951                 RETURN;
1952             }
1953             goto generic;
1954         }
1955         else if (flags & SVf_NOK) {
1956             /* both args are NVs */
1957             NV nl = SvNVX(svl);
1958             NV nr = SvNVX(svr);
1959
1960             if (
1961 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1962                 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
1963                 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
1964 #else
1965                 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
1966 #endif
1967                 )
1968                 /* nothing was lost by converting to IVs */
1969                 goto do_iv;
1970             SP--;
1971             TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1972             SETs(TARG);
1973             RETURN;
1974         }
1975     }
1976
1977   generic:
1978
1979     useleft = USE_LEFT(svl);
1980     /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1981        "bad things" happen if you rely on signed integers wrapping.  */
1982     if (SvIV_please_nomg(svr)) {
1983         /* Unless the left argument is integer in range we are going to have to
1984            use NV maths. Hence only attempt to coerce the right argument if
1985            we know the left is integer.  */
1986         UV auv = 0;
1987         bool auvok = FALSE;
1988         bool a_valid = 0;
1989
1990         if (!useleft) {
1991             auv = 0;
1992             a_valid = auvok = 1;
1993             /* left operand is undef, treat as zero.  */
1994         } else {
1995             /* Left operand is defined, so is it IV? */
1996             if (SvIV_please_nomg(svl)) {
1997                 if ((auvok = SvUOK(svl)))
1998                     auv = SvUVX(svl);
1999                 else {
2000                     const IV aiv = SvIVX(svl);
2001                     if (aiv >= 0) {
2002                         auv = aiv;
2003                         auvok = 1;      /* Now acting as a sign flag.  */
2004                     } else { /* 2s complement assumption for IV_MIN */
2005                         auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv;
2006                     }
2007                 }
2008                 a_valid = 1;
2009             }
2010         }
2011         if (a_valid) {
2012             bool result_good = 0;
2013             UV result;
2014             UV buv;
2015             bool buvok = SvUOK(svr);
2016
2017             if (buvok)
2018                 buv = SvUVX(svr);
2019             else {
2020                 const IV biv = SvIVX(svr);
2021                 if (biv >= 0) {
2022                     buv = biv;
2023                     buvok = 1;
2024                 } else
2025                     buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv;
2026             }
2027             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
2028                else "IV" now, independent of how it came in.
2029                if a, b represents positive, A, B negative, a maps to -A etc
2030                a - b =>  (a - b)
2031                A - b => -(a + b)
2032                a - B =>  (a + b)
2033                A - B => -(a - b)
2034                all UV maths. negate result if A negative.
2035                subtract if signs same, add if signs differ. */
2036
2037             if (auvok ^ buvok) {
2038                 /* Signs differ.  */
2039                 result = auv + buv;
2040                 if (result >= auv)
2041                     result_good = 1;
2042             } else {
2043                 /* Signs same */
2044                 if (auv >= buv) {
2045                     result = auv - buv;
2046                     /* Must get smaller */
2047                     if (result <= auv)
2048                         result_good = 1;
2049                 } else {
2050                     result = buv - auv;
2051                     if (result <= buv) {
2052                         /* result really should be -(auv-buv). as its negation
2053                            of true value, need to swap our result flag  */
2054                         auvok = !auvok;
2055                         result_good = 1;
2056                     }
2057                 }
2058             }
2059             if (result_good) {
2060                 SP--;
2061                 if (auvok)
2062                     SETu( result );
2063                 else {
2064                     /* Negate result */
2065                     if (result <= (UV)IV_MIN)
2066                         SETi(result == (UV)IV_MIN
2067                                 ? IV_MIN : -(IV)result);
2068                     else {
2069                         /* result valid, but out of range for IV.  */
2070                         SETn( -(NV)result );
2071                     }
2072                 }
2073                 RETURN;
2074             } /* Overflow, drop through to NVs.  */
2075         }
2076     }
2077 #else
2078     useleft = USE_LEFT(svl);
2079 #endif
2080     {
2081         NV value = SvNV_nomg(svr);
2082         (void)POPs;
2083
2084         if (!useleft) {
2085             /* left operand is undef, treat as zero - value */
2086             SETn(-value);
2087             RETURN;
2088         }
2089         SETn( SvNV_nomg(svl) - value );
2090         RETURN;
2091     }
2092 }
2093
2094 #define IV_BITS (IVSIZE * 8)
2095
2096 static UV S_uv_shift(UV uv, int shift, bool left)
2097 {
2098    if (shift < 0) {
2099        shift = -shift;
2100        left = !left;
2101    }
2102    if (shift >= IV_BITS) {
2103        return 0;
2104    }
2105    return left ? uv << shift : uv >> shift;
2106 }
2107
2108 static IV S_iv_shift(IV iv, int shift, bool left)
2109 {
2110    if (shift < 0) {
2111        shift = -shift;
2112        left = !left;
2113    }
2114    if (shift >= IV_BITS) {
2115        return iv < 0 && !left ? -1 : 0;
2116    }
2117    return left ? iv << shift : iv >> shift;
2118 }
2119
2120 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2121 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2122 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2123 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2124
2125 PP(pp_left_shift)
2126 {
2127     dSP; dATARGET; SV *svl, *svr;
2128     tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2129     svr = POPs;
2130     svl = TOPs;
2131     {
2132       const IV shift = SvIV_nomg(svr);
2133       if (PL_op->op_private & HINT_INTEGER) {
2134           SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2135       }
2136       else {
2137           SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2138       }
2139       RETURN;
2140     }
2141 }
2142
2143 PP(pp_right_shift)
2144 {
2145     dSP; dATARGET; SV *svl, *svr;
2146     tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2147     svr = POPs;
2148     svl = TOPs;
2149     {
2150       const IV shift = SvIV_nomg(svr);
2151       if (PL_op->op_private & HINT_INTEGER) {
2152           SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2153       }
2154       else {
2155           SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2156       }
2157       RETURN;
2158     }
2159 }
2160
2161 PP(pp_lt)
2162 {
2163     dSP;
2164     SV *left, *right;
2165
2166     tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
2167     right = POPs;
2168     left  = TOPs;
2169     SETs(boolSV(
2170         (SvIOK_notUV(left) && SvIOK_notUV(right))
2171         ? (SvIVX(left) < SvIVX(right))
2172         : (do_ncmp(left, right) == -1)
2173     ));
2174     RETURN;
2175 }
2176
2177 PP(pp_gt)
2178 {
2179     dSP;
2180     SV *left, *right;
2181
2182     tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2183     right = POPs;
2184     left  = TOPs;
2185     SETs(boolSV(
2186         (SvIOK_notUV(left) && SvIOK_notUV(right))
2187         ? (SvIVX(left) > SvIVX(right))
2188         : (do_ncmp(left, right) == 1)
2189     ));
2190     RETURN;
2191 }
2192
2193 PP(pp_le)
2194 {
2195     dSP;
2196     SV *left, *right;
2197
2198     tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2199     right = POPs;
2200     left  = TOPs;
2201     SETs(boolSV(
2202         (SvIOK_notUV(left) && SvIOK_notUV(right))
2203         ? (SvIVX(left) <= SvIVX(right))
2204         : (do_ncmp(left, right) <= 0)
2205     ));
2206     RETURN;
2207 }
2208
2209 PP(pp_ge)
2210 {
2211     dSP;
2212     SV *left, *right;
2213
2214     tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2215     right = POPs;
2216     left  = TOPs;
2217     SETs(boolSV(
2218         (SvIOK_notUV(left) && SvIOK_notUV(right))
2219         ? (SvIVX(left) >= SvIVX(right))
2220         : ( (do_ncmp(left, right) & 2) == 0)
2221     ));
2222     RETURN;
2223 }
2224
2225 PP(pp_ne)
2226 {
2227     dSP;
2228     SV *left, *right;
2229
2230     tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2231     right = POPs;
2232     left  = TOPs;
2233     SETs(boolSV(
2234         (SvIOK_notUV(left) && SvIOK_notUV(right))
2235         ? (SvIVX(left) != SvIVX(right))
2236         : (do_ncmp(left, right) != 0)
2237     ));
2238     RETURN;
2239 }
2240
2241 /* compare left and right SVs. Returns:
2242  * -1: <
2243  *  0: ==
2244  *  1: >
2245  *  2: left or right was a NaN
2246  */
2247 I32
2248 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2249 {
2250     PERL_ARGS_ASSERT_DO_NCMP;
2251 #ifdef PERL_PRESERVE_IVUV
2252     /* Fortunately it seems NaN isn't IOK */
2253     if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2254             if (!SvUOK(left)) {
2255                 const IV leftiv = SvIVX(left);
2256                 if (!SvUOK(right)) {
2257                     /* ## IV <=> IV ## */
2258                     const IV rightiv = SvIVX(right);
2259                     return (leftiv > rightiv) - (leftiv < rightiv);
2260                 }
2261                 /* ## IV <=> UV ## */
2262                 if (leftiv < 0)
2263                     /* As (b) is a UV, it's >=0, so it must be < */
2264                     return -1;
2265                 {
2266                     const UV rightuv = SvUVX(right);
2267                     return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2268                 }
2269             }
2270
2271             if (SvUOK(right)) {
2272                 /* ## UV <=> UV ## */
2273                 const UV leftuv = SvUVX(left);
2274                 const UV rightuv = SvUVX(right);
2275                 return (leftuv > rightuv) - (leftuv < rightuv);
2276             }
2277             /* ## UV <=> IV ## */
2278             {
2279                 const IV rightiv = SvIVX(right);
2280                 if (rightiv < 0)
2281                     /* As (a) is a UV, it's >=0, so it cannot be < */
2282                     return 1;
2283                 {
2284                     const UV leftuv = SvUVX(left);
2285                     return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2286                 }
2287             }
2288             NOT_REACHED; /* NOTREACHED */
2289     }
2290 #endif
2291     {
2292       NV const rnv = SvNV_nomg(right);
2293       NV const lnv = SvNV_nomg(left);
2294
2295 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2296       if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2297           return 2;
2298        }
2299       return (lnv > rnv) - (lnv < rnv);
2300 #else
2301       if (lnv < rnv)
2302         return -1;
2303       if (lnv > rnv)
2304         return 1;
2305       if (lnv == rnv)
2306         return 0;
2307       return 2;
2308 #endif
2309     }
2310 }
2311
2312
2313 PP(pp_ncmp)
2314 {
2315     dSP;
2316     SV *left, *right;
2317     I32 value;
2318     tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2319     right = POPs;
2320     left  = TOPs;
2321     value = do_ncmp(left, right);
2322     if (value == 2) {
2323         SETs(&PL_sv_undef);
2324     }
2325     else {
2326         dTARGET;
2327         SETi(value);
2328     }
2329     RETURN;
2330 }
2331
2332
2333 /* also used for: pp_sge() pp_sgt() pp_slt() */
2334
2335 PP(pp_sle)
2336 {
2337     dSP;
2338
2339     int amg_type = sle_amg;
2340     int multiplier = 1;
2341     int rhs = 1;
2342
2343     switch (PL_op->op_type) {
2344     case OP_SLT:
2345         amg_type = slt_amg;
2346         /* cmp < 0 */
2347         rhs = 0;
2348         break;
2349     case OP_SGT:
2350         amg_type = sgt_amg;
2351         /* cmp > 0 */
2352         multiplier = -1;
2353         rhs = 0;
2354         break;
2355     case OP_SGE:
2356         amg_type = sge_amg;
2357         /* cmp >= 0 */
2358         multiplier = -1;
2359         break;
2360     }
2361
2362     tryAMAGICbin_MG(amg_type, AMGf_set);
2363     {
2364       dPOPTOPssrl;
2365       const int cmp =
2366 #ifdef USE_LOCALE_COLLATE
2367                       (IN_LC_RUNTIME(LC_COLLATE))
2368                       ? sv_cmp_locale_flags(left, right, 0)
2369                       :
2370 #endif
2371                         sv_cmp_flags(left, right, 0);
2372       SETs(boolSV(cmp * multiplier < rhs));
2373       RETURN;
2374     }
2375 }
2376
2377 PP(pp_seq)
2378 {
2379     dSP;
2380     tryAMAGICbin_MG(seq_amg, AMGf_set);
2381     {
2382       dPOPTOPssrl;
2383       SETs(boolSV(sv_eq_flags(left, right, 0)));
2384       RETURN;
2385     }
2386 }
2387
2388 PP(pp_sne)
2389 {
2390     dSP;
2391     tryAMAGICbin_MG(sne_amg, AMGf_set);
2392     {
2393       dPOPTOPssrl;
2394       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2395       RETURN;
2396     }
2397 }
2398
2399 PP(pp_scmp)
2400 {
2401     dSP; dTARGET;
2402     tryAMAGICbin_MG(scmp_amg, 0);
2403     {
2404       dPOPTOPssrl;
2405       const int cmp =
2406 #ifdef USE_LOCALE_COLLATE
2407                       (IN_LC_RUNTIME(LC_COLLATE))
2408                       ? sv_cmp_locale_flags(left, right, 0)
2409                       :
2410 #endif
2411                         sv_cmp_flags(left, right, 0);
2412       SETi( cmp );
2413       RETURN;
2414     }
2415 }
2416
2417 PP(pp_bit_and)
2418 {
2419     dSP; dATARGET;
2420     tryAMAGICbin_MG(band_amg, AMGf_assign);
2421     {
2422       dPOPTOPssrl;
2423       if (SvNIOKp(left) || SvNIOKp(right)) {
2424         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2425         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2426         if (PL_op->op_private & HINT_INTEGER) {
2427           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2428           SETi(i);
2429         }
2430         else {
2431           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2432           SETu(u);
2433         }
2434         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2435         if (right_ro_nonnum) SvNIOK_off(right);
2436       }
2437       else {
2438         do_vop(PL_op->op_type, TARG, left, right);
2439         SETTARG;
2440       }
2441       RETURN;
2442     }
2443 }
2444
2445 PP(pp_nbit_and)
2446 {
2447     dSP;
2448     tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2449     {
2450         dATARGET; dPOPTOPssrl;
2451         if (PL_op->op_private & HINT_INTEGER) {
2452           const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2453           SETi(i);
2454         }
2455         else {
2456           const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2457           SETu(u);
2458         }
2459     }
2460     RETURN;
2461 }
2462
2463 PP(pp_sbit_and)
2464 {
2465     dSP;
2466     tryAMAGICbin_MG(sband_amg, AMGf_assign);
2467     {
2468         dATARGET; dPOPTOPssrl;
2469         do_vop(OP_BIT_AND, TARG, left, right);
2470         RETSETTARG;
2471     }
2472 }
2473
2474 /* also used for: pp_bit_xor() */
2475
2476 PP(pp_bit_or)
2477 {
2478     dSP; dATARGET;
2479     const int op_type = PL_op->op_type;
2480
2481     tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2482     {
2483       dPOPTOPssrl;
2484       if (SvNIOKp(left) || SvNIOKp(right)) {
2485         const bool left_ro_nonnum  = !SvNIOKp(left) && SvREADONLY(left);
2486         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2487         if (PL_op->op_private & HINT_INTEGER) {
2488           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2489           const IV r = SvIV_nomg(right);
2490           const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2491           SETi(result);
2492         }
2493         else {
2494           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2495           const UV r = SvUV_nomg(right);
2496           const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2497           SETu(result);
2498         }
2499         if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2500         if (right_ro_nonnum) SvNIOK_off(right);
2501       }
2502       else {
2503         do_vop(op_type, TARG, left, right);
2504         SETTARG;
2505       }
2506       RETURN;
2507     }
2508 }
2509
2510 /* also used for: pp_nbit_xor() */
2511
2512 PP(pp_nbit_or)
2513 {
2514     dSP;
2515     const int op_type = PL_op->op_type;
2516
2517     tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2518                     AMGf_assign|AMGf_numarg);
2519     {
2520         dATARGET; dPOPTOPssrl;
2521         if (PL_op->op_private & HINT_INTEGER) {
2522           const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2523           const IV r = SvIV_nomg(right);
2524           const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2525           SETi(result);
2526         }
2527         else {
2528           const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2529           const UV r = SvUV_nomg(right);
2530           const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2531           SETu(result);
2532         }
2533     }
2534     RETURN;
2535 }
2536
2537 /* also used for: pp_sbit_xor() */
2538
2539 PP(pp_sbit_or)
2540 {
2541     dSP;
2542     const int op_type = PL_op->op_type;
2543
2544     tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2545                     AMGf_assign);
2546     {
2547         dATARGET; dPOPTOPssrl;
2548         do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2549                right);
2550         RETSETTARG;
2551     }
2552 }
2553
2554 PERL_STATIC_INLINE bool
2555 S_negate_string(pTHX)
2556 {
2557     dTARGET; dSP;
2558     STRLEN len;
2559     const char *s;
2560     SV * const sv = TOPs;
2561     if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2562         return FALSE;
2563     s = SvPV_nomg_const(sv, len);
2564     if (isIDFIRST(*s)) {
2565         sv_setpvs(TARG, "-");
2566         sv_catsv(TARG, sv);
2567     }
2568     else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2569         sv_setsv_nomg(TARG, sv);
2570         *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2571     }
2572     else return FALSE;
2573     SETTARG;
2574     return TRUE;
2575 }
2576
2577 PP(pp_negate)
2578 {
2579     dSP; dTARGET;
2580     tryAMAGICun_MG(neg_amg, AMGf_numeric);
2581     if (S_negate_string(aTHX)) return NORMAL;
2582     {
2583         SV * const sv = TOPs;
2584
2585         if (SvIOK(sv)) {
2586             /* It's publicly an integer */
2587         oops_its_an_int:
2588             if (SvIsUV(sv)) {
2589                 if (SvIVX(sv) == IV_MIN) {
2590                     /* 2s complement assumption. */
2591                     SETi(SvIVX(sv));    /* special case: -((UV)IV_MAX+1) ==
2592                                            IV_MIN */
2593                     return NORMAL;
2594                 }
2595                 else if (SvUVX(sv) <= IV_MAX) {
2596                     SETi(-SvIVX(sv));
2597                     return NORMAL;
2598                 }
2599             }
2600             else if (SvIVX(sv) != IV_MIN) {
2601                 SETi(-SvIVX(sv));
2602                 return NORMAL;
2603             }
2604 #ifdef PERL_PRESERVE_IVUV
2605             else {
2606                 SETu((UV)IV_MIN);
2607                 return NORMAL;
2608             }
2609 #endif
2610         }
2611         if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2612             SETn(-SvNV_nomg(sv));
2613         else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2614                   goto oops_its_an_int;
2615         else
2616             SETn(-SvNV_nomg(sv));
2617     }
2618     return NORMAL;
2619 }
2620
2621 PP(pp_not)
2622 {
2623     dSP;
2624     tryAMAGICun_MG(not_amg, AMGf_set);
2625     *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2626     return NORMAL;
2627 }
2628
2629 static void
2630 S_scomplement(pTHX_ SV *targ, SV *sv)
2631 {
2632         U8 *tmps;
2633         I32 anum;
2634         STRLEN len;
2635
2636         sv_copypv_nomg(TARG, sv);
2637         tmps = (U8*)SvPV_nomg(TARG, len);
2638
2639         if (SvUTF8(TARG)) {
2640             if (len && ! utf8_to_bytes(tmps, &len)) {
2641                 Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[PL_op->op_type]);
2642             }
2643             SvCUR(TARG) = len;
2644             SvUTF8_off(TARG);
2645         }
2646
2647         anum = len;
2648
2649 #ifdef LIBERAL
2650         {
2651             long *tmpl;
2652             for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2653                 *tmps = ~*tmps;
2654             tmpl = (long*)tmps;
2655             for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2656                 *tmpl = ~*tmpl;
2657             tmps = (U8*)tmpl;
2658         }
2659 #endif
2660         for ( ; anum > 0; anum--, tmps++)
2661             *tmps = ~*tmps;
2662 }
2663
2664 PP(pp_complement)
2665 {
2666     dSP; dTARGET;
2667     tryAMAGICun_MG(compl_amg, AMGf_numeric);
2668     {
2669       dTOPss;
2670       if (SvNIOKp(sv)) {
2671         if (PL_op->op_private & HINT_INTEGER) {
2672           const IV i = ~SvIV_nomg(sv);
2673           SETi(i);
2674         }
2675         else {
2676           const UV u = ~SvUV_nomg(sv);
2677           SETu(u);
2678         }
2679       }
2680       else {
2681         S_scomplement(aTHX_ TARG, sv);
2682         SETTARG;
2683       }
2684       return NORMAL;
2685     }
2686 }
2687
2688 PP(pp_ncomplement)
2689 {
2690     dSP;
2691     tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2692     {
2693         dTARGET; dTOPss;
2694         if (PL_op->op_private & HINT_INTEGER) {
2695           const IV i = ~SvIV_nomg(sv);
2696           SETi(i);
2697         }
2698         else {
2699           const UV u = ~SvUV_nomg(sv);
2700           SETu(u);
2701         }
2702     }
2703     return NORMAL;
2704 }
2705
2706 PP(pp_scomplement)
2707 {
2708     dSP;
2709     tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2710     {
2711         dTARGET; dTOPss;
2712         S_scomplement(aTHX_ TARG, sv);
2713         SETTARG;
2714         return NORMAL;
2715     }
2716 }
2717
2718 /* integer versions of some of the above */
2719
2720 PP(pp_i_multiply)
2721 {
2722     dSP; dATARGET;
2723     tryAMAGICbin_MG(mult_amg, AMGf_assign);
2724     {
2725       dPOPTOPiirl_nomg;
2726       SETi( left * right );
2727       RETURN;
2728     }
2729 }
2730
2731 PP(pp_i_divide)
2732 {
2733     IV num;
2734     dSP; dATARGET;
2735     tryAMAGICbin_MG(div_amg, AMGf_assign);
2736     {
2737       dPOPTOPssrl;
2738       IV value = SvIV_nomg(right);
2739       if (value == 0)
2740           DIE(aTHX_ "Illegal division by zero");
2741       num = SvIV_nomg(left);
2742
2743       /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2744       if (value == -1)
2745           value = - num;
2746       else
2747           value = num / value;
2748       SETi(value);
2749       RETURN;
2750     }
2751 }
2752
2753 PP(pp_i_modulo)
2754 {
2755      /* This is the vanilla old i_modulo. */
2756      dSP; dATARGET;
2757      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2758      {
2759           dPOPTOPiirl_nomg;
2760           if (!right)
2761                DIE(aTHX_ "Illegal modulus zero");
2762           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2763           if (right == -1)
2764               SETi( 0 );
2765           else
2766               SETi( left % right );
2767           RETURN;
2768      }
2769 }
2770
2771 #if defined(__GLIBC__) && IVSIZE == 8 \
2772     && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2773
2774 PP(pp_i_modulo_glibc_bugfix)
2775 {
2776      /* This is the i_modulo with the workaround for the _moddi3 bug
2777       * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2778       * See below for pp_i_modulo. */
2779      dSP; dATARGET;
2780      tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2781      {
2782           dPOPTOPiirl_nomg;
2783           if (!right)
2784                DIE(aTHX_ "Illegal modulus zero");
2785           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2786           if (right == -1)
2787               SETi( 0 );
2788           else
2789               SETi( left % PERL_ABS(right) );
2790           RETURN;
2791      }
2792 }
2793 #endif
2794
2795 PP(pp_i_add)
2796 {
2797     dSP; dATARGET;
2798     tryAMAGICbin_MG(add_amg, AMGf_assign);
2799     {
2800       dPOPTOPiirl_ul_nomg;
2801       SETi( left + right );
2802       RETURN;
2803     }
2804 }
2805
2806 PP(pp_i_subtract)
2807 {
2808     dSP; dATARGET;
2809     tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2810     {
2811       dPOPTOPiirl_ul_nomg;
2812       SETi( left - right );
2813       RETURN;
2814     }
2815 }
2816
2817 PP(pp_i_lt)
2818 {
2819     dSP;
2820     tryAMAGICbin_MG(lt_amg, AMGf_set);
2821     {
2822       dPOPTOPiirl_nomg;
2823       SETs(boolSV(left < right));
2824       RETURN;
2825     }
2826 }
2827
2828 PP(pp_i_gt)
2829 {
2830     dSP;
2831     tryAMAGICbin_MG(gt_amg, AMGf_set);
2832     {
2833       dPOPTOPiirl_nomg;
2834       SETs(boolSV(left > right));
2835       RETURN;
2836     }
2837 }
2838
2839 PP(pp_i_le)
2840 {
2841     dSP;
2842     tryAMAGICbin_MG(le_amg, AMGf_set);
2843     {
2844       dPOPTOPiirl_nomg;
2845       SETs(boolSV(left <= right));
2846       RETURN;
2847     }
2848 }
2849
2850 PP(pp_i_ge)
2851 {
2852     dSP;
2853     tryAMAGICbin_MG(ge_amg, AMGf_set);
2854     {
2855       dPOPTOPiirl_nomg;
2856       SETs(boolSV(left >= right));
2857       RETURN;
2858     }
2859 }
2860
2861 PP(pp_i_eq)
2862 {
2863     dSP;
2864     tryAMAGICbin_MG(eq_amg, AMGf_set);
2865     {
2866       dPOPTOPiirl_nomg;
2867       SETs(boolSV(left == right));
2868       RETURN;
2869     }
2870 }
2871
2872 PP(pp_i_ne)
2873 {
2874     dSP;
2875     tryAMAGICbin_MG(ne_amg, AMGf_set);
2876     {
2877       dPOPTOPiirl_nomg;
2878       SETs(boolSV(left != right));
2879       RETURN;
2880     }
2881 }
2882
2883 PP(pp_i_ncmp)
2884 {
2885     dSP; dTARGET;
2886     tryAMAGICbin_MG(ncmp_amg, 0);
2887     {
2888       dPOPTOPiirl_nomg;
2889       I32 value;
2890
2891       if (left > right)
2892         value = 1;
2893       else if (left < right)
2894         value = -1;
2895       else
2896         value = 0;
2897       SETi(value);
2898       RETURN;
2899     }
2900 }
2901
2902 PP(pp_i_negate)
2903 {
2904     dSP; dTARGET;
2905     tryAMAGICun_MG(neg_amg, 0);
2906     if (S_negate_string(aTHX)) return NORMAL;
2907     {
2908         SV * const sv = TOPs;
2909         IV const i = SvIV_nomg(sv);
2910         SETi(-i);
2911         return NORMAL;
2912     }
2913 }
2914
2915 /* High falutin' math. */
2916
2917 PP(pp_atan2)
2918 {
2919     dSP; dTARGET;
2920     tryAMAGICbin_MG(atan2_amg, 0);
2921     {
2922       dPOPTOPnnrl_nomg;
2923       SETn(Perl_atan2(left, right));
2924       RETURN;
2925     }
2926 }
2927
2928
2929 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2930
2931 PP(pp_sin)
2932 {
2933     dSP; dTARGET;
2934     int amg_type = fallback_amg;
2935     const char *neg_report = NULL;
2936     const int op_type = PL_op->op_type;
2937
2938     switch (op_type) {
2939     case OP_SIN:  amg_type = sin_amg; break;
2940     case OP_COS:  amg_type = cos_amg; break;
2941     case OP_EXP:  amg_type = exp_amg; break;
2942     case OP_LOG:  amg_type = log_amg;  neg_report = "log";  break;
2943     case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2944     }
2945
2946     assert(amg_type != fallback_amg);
2947
2948     tryAMAGICun_MG(amg_type, 0);
2949     {
2950       SV * const arg = TOPs;
2951       const NV value = SvNV_nomg(arg);
2952 #ifdef NV_NAN
2953       NV result = NV_NAN;
2954 #else
2955       NV result = 0.0;
2956 #endif
2957       if (neg_report) { /* log or sqrt */
2958           if (
2959 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2960               ! Perl_isnan(value) &&
2961 #endif
2962               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2963               SET_NUMERIC_STANDARD();
2964               /* diag_listed_as: Can't take log of %g */
2965               DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2966           }
2967       }
2968       switch (op_type) {
2969       default:
2970       case OP_SIN:  result = Perl_sin(value);  break;
2971       case OP_COS:  result = Perl_cos(value);  break;
2972       case OP_EXP:  result = Perl_exp(value);  break;
2973       case OP_LOG:  result = Perl_log(value);  break;
2974       case OP_SQRT: result = Perl_sqrt(value); break;
2975       }
2976       SETn(result);
2977       return NORMAL;
2978     }
2979 }
2980
2981 /* Support Configure command-line overrides for rand() functions.
2982    After 5.005, perhaps we should replace this by Configure support
2983    for drand48(), random(), or rand().  For 5.005, though, maintain
2984    compatibility by calling rand() but allow the user to override it.
2985    See INSTALL for details.  --Andy Dougherty  15 July 1998
2986 */
2987 /* Now it's after 5.005, and Configure supports drand48() and random(),
2988    in addition to rand().  So the overrides should not be needed any more.
2989    --Jarkko Hietaniemi  27 September 1998
2990  */
2991
2992 PP(pp_rand)
2993 {
2994     if (!PL_srand_called) {
2995         (void)seedDrand01((Rand_seed_t)seed());
2996         PL_srand_called = TRUE;
2997     }
2998     {
2999         dSP;
3000         NV value;
3001
3002         if (MAXARG < 1)
3003         {
3004             EXTEND(SP, 1);
3005             value = 1.0;
3006         }
3007         else {
3008             SV * const sv = POPs;
3009             if(!sv)
3010                 value = 1.0;
3011             else
3012                 value = SvNV(sv);
3013         }
3014     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3015 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3016         if (! Perl_isnan(value) && value == 0.0)
3017 #else
3018         if (value == 0.0)
3019 #endif
3020             value = 1.0;
3021         {
3022             dTARGET;
3023             PUSHs(TARG);
3024             PUTBACK;
3025             value *= Drand01();
3026             sv_setnv_mg(TARG, value);
3027         }
3028     }
3029     return NORMAL;
3030 }
3031
3032 PP(pp_srand)
3033 {
3034     dSP; dTARGET;
3035     UV anum;
3036
3037     if (MAXARG >= 1 && (TOPs || POPs)) {
3038         SV *top;
3039         char *pv;
3040         STRLEN len;
3041         int flags;
3042
3043         top = POPs;
3044         pv = SvPV(top, len);
3045         flags = grok_number(pv, len, &anum);
3046
3047         if (!(flags & IS_NUMBER_IN_UV)) {
3048             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3049                              "Integer overflow in srand");
3050             anum = UV_MAX;
3051         }
3052     }
3053     else {
3054         anum = seed();
3055     }
3056
3057     (void)seedDrand01((Rand_seed_t)anum);
3058     PL_srand_called = TRUE;
3059     if (anum)
3060         XPUSHu(anum);
3061     else {
3062         /* Historically srand always returned true. We can avoid breaking
3063            that like this:  */
3064         sv_setpvs(TARG, "0 but true");
3065         XPUSHTARG;
3066     }
3067     RETURN;
3068 }
3069
3070 PP(pp_int)
3071 {
3072     dSP; dTARGET;
3073     tryAMAGICun_MG(int_amg, AMGf_numeric);
3074     {
3075       SV * const sv = TOPs;
3076       const IV iv = SvIV_nomg(sv);
3077       /* XXX it's arguable that compiler casting to IV might be subtly
3078          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3079          else preferring IV has introduced a subtle behaviour change bug. OTOH
3080          relying on floating point to be accurate is a bug.  */
3081
3082       if (!SvOK(sv)) {
3083         SETu(0);
3084       }
3085       else if (SvIOK(sv)) {
3086         if (SvIsUV(sv))
3087             SETu(SvUV_nomg(sv));
3088         else
3089             SETi(iv);
3090       }
3091       else {
3092           const NV value = SvNV_nomg(sv);
3093           if (UNLIKELY(Perl_isinfnan(value)))
3094               SETn(value);
3095           else if (value >= 0.0) {
3096               if (value < (NV)UV_MAX + 0.5) {
3097                   SETu(U_V(value));
3098               } else {
3099                   SETn(Perl_floor(value));
3100               }
3101           }
3102           else {
3103               if (value > (NV)IV_MIN - 0.5) {
3104                   SETi(I_V(value));
3105               } else {
3106                   SETn(Perl_ceil(value));
3107               }
3108           }
3109       }
3110     }
3111     return NORMAL;
3112 }
3113
3114 PP(pp_abs)
3115 {
3116     dSP; dTARGET;
3117     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3118     {
3119       SV * const sv = TOPs;
3120       /* This will cache the NV value if string isn't actually integer  */
3121       const IV iv = SvIV_nomg(sv);
3122
3123       if (!SvOK(sv)) {
3124         SETu(0);
3125       }
3126       else if (SvIOK(sv)) {
3127         /* IVX is precise  */
3128         if (SvIsUV(sv)) {
3129           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3130         } else {
3131           if (iv >= 0) {
3132             SETi(iv);
3133           } else {
3134             if (iv != IV_MIN) {
3135               SETi(-iv);
3136             } else {
3137               /* 2s complement assumption. Also, not really needed as
3138                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3139               SETu((UV)IV_MIN);
3140             }
3141           }
3142         }
3143       } else{
3144         const NV value = SvNV_nomg(sv);
3145         if (value < 0.0)
3146           SETn(-value);
3147         else
3148           SETn(value);
3149       }
3150     }
3151     return NORMAL;
3152 }
3153
3154
3155 /* also used for: pp_hex() */
3156
3157 PP(pp_oct)
3158 {
3159     dSP; dTARGET;
3160     const char *tmps;
3161     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3162     STRLEN len;
3163     NV result_nv;
3164     UV result_uv;
3165     SV* const sv = TOPs;
3166
3167     tmps = (SvPV_const(sv, len));
3168     if (DO_UTF8(sv)) {
3169          /* If Unicode, try to downgrade
3170           * If not possible, croak. */
3171          SV* const tsv = sv_2mortal(newSVsv(sv));
3172
3173          SvUTF8_on(tsv);
3174          sv_utf8_downgrade(tsv, FALSE);
3175          tmps = SvPV_const(tsv, len);
3176     }
3177     if (PL_op->op_type == OP_HEX)
3178         goto hex;
3179
3180     while (*tmps && len && isSPACE(*tmps))
3181         tmps++, len--;
3182     if (*tmps == '0')
3183         tmps++, len--;
3184     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3185     hex:
3186         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3187     }
3188     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3189         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3190     else
3191         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3192
3193     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3194         SETn(result_nv);
3195     }
3196     else {
3197         SETu(result_uv);
3198     }
3199     return NORMAL;
3200 }
3201
3202 /* String stuff. */
3203
3204 PP(pp_length)
3205 {
3206     dSP; dTARGET;
3207     SV * const sv = TOPs;
3208
3209     U32 in_bytes = IN_BYTES;
3210     /* simplest case shortcut */
3211     /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3212     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3213     STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3214     SETs(TARG);
3215
3216     if(LIKELY(svflags == SVf_POK))
3217         goto simple_pv;
3218     if(svflags & SVs_GMG)
3219         mg_get(sv);
3220     if (SvOK(sv)) {
3221         if (!IN_BYTES) /* reread to avoid using an C auto/register */
3222             sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3223         else
3224         {
3225             STRLEN len;
3226             /* unrolled SvPV_nomg_const(sv,len) */
3227             if(SvPOK_nog(sv)){
3228                 simple_pv:
3229                 len = SvCUR(sv);
3230             } else  {
3231                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3232             }
3233             sv_setiv(TARG, (IV)(len));
3234         }
3235     } else {
3236         if (!SvPADTMP(TARG)) {
3237             sv_set_undef(TARG);
3238         } else { /* TARG is on stack at this point and is overwriten by SETs.
3239                    This branch is the odd one out, so put TARG by default on
3240                    stack earlier to let local SP go out of liveness sooner */
3241             SETs(&PL_sv_undef);
3242             goto no_set_magic;
3243         }
3244     }
3245     SvSETMAGIC(TARG);
3246     no_set_magic:
3247     return NORMAL; /* no putback, SP didn't move in this opcode */
3248 }
3249
3250 /* Returns false if substring is completely outside original string.
3251    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3252    always be true for an explicit 0.
3253 */
3254 bool
3255 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3256                                 bool pos1_is_uv, IV len_iv,
3257                                 bool len_is_uv, STRLEN *posp,
3258                                 STRLEN *lenp)
3259 {
3260     IV pos2_iv;
3261     int    pos2_is_uv;
3262
3263     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3264
3265     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3266         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3267         pos1_iv += curlen;
3268     }
3269     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3270         return FALSE;
3271
3272     if (len_iv || len_is_uv) {
3273         if (!len_is_uv && len_iv < 0) {
3274             pos2_iv = curlen + len_iv;
3275             if (curlen)
3276                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3277             else
3278                 pos2_is_uv = 0;
3279         } else {  /* len_iv >= 0 */
3280             if (!pos1_is_uv && pos1_iv < 0) {
3281                 pos2_iv = pos1_iv + len_iv;
3282                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3283             } else {
3284                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3285                     pos2_iv = curlen;
3286                 else
3287                     pos2_iv = pos1_iv+len_iv;
3288                 pos2_is_uv = 1;
3289             }
3290         }
3291     }
3292     else {
3293         pos2_iv = curlen;
3294         pos2_is_uv = 1;
3295     }
3296
3297     if (!pos2_is_uv && pos2_iv < 0) {
3298         if (!pos1_is_uv && pos1_iv < 0)
3299             return FALSE;
3300         pos2_iv = 0;
3301     }
3302     else if (!pos1_is_uv && pos1_iv < 0)
3303         pos1_iv = 0;
3304
3305     if ((UV)pos2_iv < (UV)pos1_iv)
3306         pos2_iv = pos1_iv;
3307     if ((UV)pos2_iv > curlen)
3308         pos2_iv = curlen;
3309
3310     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3311     *posp = (STRLEN)( (UV)pos1_iv );
3312     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3313
3314     return TRUE;
3315 }
3316
3317 PP(pp_substr)
3318 {
3319     dSP; dTARGET;
3320     SV *sv;
3321     STRLEN curlen;
3322     STRLEN utf8_curlen;
3323     SV *   pos_sv;
3324     IV     pos1_iv;
3325     int    pos1_is_uv;
3326     SV *   len_sv;
3327     IV     len_iv = 0;
3328     int    len_is_uv = 0;
3329     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3330     const bool rvalue = (GIMME_V != G_VOID);
3331     const char *tmps;
3332     SV *repl_sv = NULL;
3333     const char *repl = NULL;
3334     STRLEN repl_len;
3335     int num_args = PL_op->op_private & 7;
3336     bool repl_need_utf8_upgrade = FALSE;
3337
3338     if (num_args > 2) {
3339         if (num_args > 3) {
3340           if(!(repl_sv = POPs)) num_args--;
3341         }
3342         if ((len_sv = POPs)) {
3343             len_iv    = SvIV(len_sv);
3344             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3345         }
3346         else num_args--;
3347     }
3348     pos_sv     = POPs;
3349     pos1_iv    = SvIV(pos_sv);
3350     pos1_is_uv = SvIOK_UV(pos_sv);
3351     sv = POPs;
3352     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3353         assert(!repl_sv);
3354         repl_sv = POPs;
3355     }
3356     if (lvalue && !repl_sv) {
3357         SV * ret;
3358         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3359         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3360         LvTYPE(ret) = 'x';
3361         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3362         LvTARGOFF(ret) =
3363             pos1_is_uv || pos1_iv >= 0
3364                 ? (STRLEN)(UV)pos1_iv
3365                 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3366         LvTARGLEN(ret) =
3367             len_is_uv || len_iv > 0
3368                 ? (STRLEN)(UV)len_iv
3369                 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3370
3371         PUSHs(ret);    /* avoid SvSETMAGIC here */
3372         RETURN;
3373     }
3374     if (repl_sv) {
3375         repl = SvPV_const(repl_sv, repl_len);
3376         SvGETMAGIC(sv);
3377         if (SvROK(sv))
3378             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3379                             "Attempt to use reference as lvalue in substr"
3380             );
3381         tmps = SvPV_force_nomg(sv, curlen);
3382         if (DO_UTF8(repl_sv) && repl_len) {
3383             if (!DO_UTF8(sv)) {
3384                 /* Upgrade the dest, and recalculate tmps in case the buffer
3385                  * got reallocated; curlen may also have been changed */
3386                 sv_utf8_upgrade_nomg(sv);
3387                 tmps = SvPV_nomg(sv, curlen);
3388             }
3389         }
3390         else if (DO_UTF8(sv))
3391             repl_need_utf8_upgrade = TRUE;
3392     }
3393     else tmps = SvPV_const(sv, curlen);
3394     if (DO_UTF8(sv)) {
3395         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3396         if (utf8_curlen == curlen)
3397             utf8_curlen = 0;
3398         else
3399             curlen = utf8_curlen;
3400     }
3401     else
3402         utf8_curlen = 0;
3403
3404     {
3405         STRLEN pos, len, byte_len, byte_pos;
3406
3407         if (!translate_substr_offsets(
3408                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3409         )) goto bound_fail;
3410
3411         byte_len = len;
3412         byte_pos = utf8_curlen
3413             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3414
3415         tmps += byte_pos;
3416
3417         if (rvalue) {
3418             SvTAINTED_off(TARG);                        /* decontaminate */
3419             SvUTF8_off(TARG);                   /* decontaminate */
3420             sv_setpvn(TARG, tmps, byte_len);
3421 #ifdef USE_LOCALE_COLLATE
3422             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3423 #endif
3424             if (utf8_curlen)
3425                 SvUTF8_on(TARG);
3426         }
3427
3428         if (repl) {
3429             SV* repl_sv_copy = NULL;
3430
3431             if (repl_need_utf8_upgrade) {
3432                 repl_sv_copy = newSVsv(repl_sv);
3433                 sv_utf8_upgrade(repl_sv_copy);
3434                 repl = SvPV_const(repl_sv_copy, repl_len);
3435             }
3436             if (!SvOK(sv))
3437                 SvPVCLEAR(sv);
3438             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3439             SvREFCNT_dec(repl_sv_copy);
3440         }
3441     }
3442     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3443         SP++;
3444     else if (rvalue) {
3445         SvSETMAGIC(TARG);
3446         PUSHs(TARG);
3447     }
3448     RETURN;
3449
3450   bound_fail:
3451     if (repl)
3452         Perl_croak(aTHX_ "substr outside of string");
3453     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3454     RETPUSHUNDEF;
3455 }
3456
3457 PP(pp_vec)
3458 {
3459     dSP;
3460     const IV size   = POPi;
3461     SV* offsetsv   = POPs;
3462     SV * const src = POPs;
3463     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3464     SV * ret;
3465     UV   retuv;
3466     STRLEN offset = 0;
3467     char errflags = 0;
3468
3469     /* extract a STRLEN-ranged integer value from offsetsv into offset,
3470      * or flag that its out of range */
3471     {
3472         IV iv = SvIV(offsetsv);
3473
3474         /* avoid a large UV being wrapped to a negative value */
3475         if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3476             errflags = LVf_OUT_OF_RANGE;
3477         else if (iv < 0)
3478             errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3479 #if PTRSIZE < IVSIZE
3480         else if (iv > Size_t_MAX)
3481             errflags = LVf_OUT_OF_RANGE;
3482 #endif
3483         else
3484             offset = (STRLEN)iv;
3485     }
3486
3487     retuv = errflags ? 0 : do_vecget(src, offset, size);
3488
3489     if (lvalue) {                       /* it's an lvalue! */
3490         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3491         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3492         LvTYPE(ret) = 'v';
3493         LvTARG(ret) = SvREFCNT_inc_simple(src);
3494         LvTARGOFF(ret) = offset;
3495         LvTARGLEN(ret) = size;
3496         LvFLAGS(ret)   = errflags;
3497     }
3498     else {
3499         dTARGET;
3500         SvTAINTED_off(TARG);            /* decontaminate */
3501         ret = TARG;
3502     }
3503
3504     sv_setuv(ret, retuv);
3505     if (!lvalue)
3506         SvSETMAGIC(ret);
3507     PUSHs(ret);
3508     RETURN;
3509 }
3510
3511
3512 /* also used for: pp_rindex() */
3513
3514 PP(pp_index)
3515 {
3516     dSP; dTARGET;
3517     SV *big;
3518     SV *little;
3519     SV *temp = NULL;
3520     STRLEN biglen;
3521     STRLEN llen = 0;
3522     SSize_t offset = 0;
3523     SSize_t retval;
3524     const char *big_p;
3525     const char *little_p;
3526     bool big_utf8;
3527     bool little_utf8;
3528     const bool is_index = PL_op->op_type == OP_INDEX;
3529     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3530
3531     if (threeargs)
3532         offset = POPi;
3533     little = POPs;
3534     big = POPs;
3535     big_p = SvPV_const(big, biglen);
3536     little_p = SvPV_const(little, llen);
3537
3538     big_utf8 = DO_UTF8(big);
3539     little_utf8 = DO_UTF8(little);
3540     if (big_utf8 ^ little_utf8) {
3541         /* One needs to be upgraded.  */
3542         if (little_utf8) {
3543             /* Well, maybe instead we might be able to downgrade the small
3544                string?  */
3545             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3546                                                      &little_utf8);
3547             if (little_utf8) {
3548                 /* If the large string is ISO-8859-1, and it's not possible to
3549                    convert the small string to ISO-8859-1, then there is no
3550                    way that it could be found anywhere by index.  */
3551                 retval = -1;
3552                 goto fail;
3553             }
3554
3555             /* At this point, pv is a malloc()ed string. So donate it to temp
3556                to ensure it will get free()d  */
3557             little = temp = newSV(0);
3558             sv_usepvn(temp, pv, llen);
3559             little_p = SvPVX(little);
3560         } else {
3561             temp = newSVpvn(little_p, llen);
3562
3563             sv_utf8_upgrade(temp);
3564             little = temp;
3565             little_p = SvPV_const(little, llen);
3566         }
3567     }
3568     if (SvGAMAGIC(big)) {
3569         /* Life just becomes a lot easier if I use a temporary here.
3570            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3571            will trigger magic and overloading again, as will fbm_instr()
3572         */
3573         big = newSVpvn_flags(big_p, biglen,
3574                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3575         big_p = SvPVX(big);
3576     }
3577     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3578         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3579            warn on undef, and we've already triggered a warning with the
3580            SvPV_const some lines above. We can't remove that, as we need to
3581            call some SvPV to trigger overloading early and find out if the
3582            string is UTF-8.
3583            This is all getting too messy. The API isn't quite clean enough,
3584            because data access has side effects.
3585         */
3586         little = newSVpvn_flags(little_p, llen,
3587                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3588         little_p = SvPVX(little);
3589     }
3590
3591     if (!threeargs)
3592         offset = is_index ? 0 : biglen;
3593     else {
3594         if (big_utf8 && offset > 0)
3595             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3596         if (!is_index)
3597             offset += llen;
3598     }
3599     if (offset < 0)
3600         offset = 0;
3601     else if (offset > (SSize_t)biglen)
3602         offset = biglen;
3603     if (!(little_p = is_index
3604           ? fbm_instr((unsigned char*)big_p + offset,
3605                       (unsigned char*)big_p + biglen, little, 0)
3606           : rninstr(big_p,  big_p  + offset,
3607                     little_p, little_p + llen)))
3608         retval = -1;
3609     else {
3610         retval = little_p - big_p;
3611         if (retval > 1 && big_utf8)
3612             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3613     }
3614     SvREFCNT_dec(temp);
3615  fail:
3616     PUSHi(retval);
3617     RETURN;
3618 }
3619
3620 PP(pp_sprintf)
3621 {
3622     dSP; dMARK; dORIGMARK; dTARGET;
3623     SvTAINTED_off(TARG);
3624     do_sprintf(TARG, SP-MARK, MARK+1);
3625     TAINT_IF(SvTAINTED(TARG));
3626     SP = ORIGMARK;
3627     PUSHTARG;
3628     RETURN;
3629 }
3630
3631 PP(pp_ord)
3632 {
3633     dSP; dTARGET;
3634
3635     SV *argsv = TOPs;
3636     STRLEN len;
3637     const U8 *s = (U8*)SvPV_const(argsv, len);
3638
3639     SETu(DO_UTF8(argsv)
3640            ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3641            : (UV)(*s));
3642
3643     return NORMAL;
3644 }
3645
3646 PP(pp_chr)
3647 {
3648     dSP; dTARGET;
3649     char *tmps;
3650     UV value;
3651     SV *top = TOPs;
3652
3653     SvGETMAGIC(top);
3654     if (UNLIKELY(SvAMAGIC(top)))
3655         top = sv_2num(top);
3656     if (UNLIKELY(isinfnansv(top)))
3657         Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3658     else {
3659         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3660             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3661                 ||
3662                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3663                  && SvNV_nomg(top) < 0.0)))
3664         {
3665             if (ckWARN(WARN_UTF8)) {
3666                 if (SvGMAGICAL(top)) {
3667                     SV *top2 = sv_newmortal();
3668                     sv_setsv_nomg(top2, top);
3669                     top = top2;
3670                 }
3671                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3672                             "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3673             }
3674             value = UNICODE_REPLACEMENT;
3675         } else {
3676             value = SvUV_nomg(top);
3677         }
3678     }
3679
3680     SvUPGRADE(TARG,SVt_PV);
3681
3682     if (value > 255 && !IN_BYTES) {
3683         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3684         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3685         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3686         *tmps = '\0';
3687         (void)SvPOK_only(TARG);
3688         SvUTF8_on(TARG);
3689         SETTARG;
3690         return NORMAL;
3691     }
3692
3693     SvGROW(TARG,2);
3694     SvCUR_set(TARG, 1);
3695     tmps = SvPVX(TARG);
3696     *tmps++ = (char)value;
3697     *tmps = '\0';
3698     (void)SvPOK_only(TARG);
3699
3700     SETTARG;
3701     return NORMAL;
3702 }
3703
3704 PP(pp_crypt)
3705 {
3706 #ifdef HAS_CRYPT
3707     dSP; dTARGET;
3708     dPOPTOPssrl;
3709     STRLEN len;
3710     const char *tmps = SvPV_const(left, len);
3711
3712     if (DO_UTF8(left)) {
3713          /* If Unicode, try to downgrade.
3714           * If not possible, croak.
3715           * Yes, we made this up.  */
3716          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3717
3718          sv_utf8_downgrade(tsv, FALSE);
3719          tmps = SvPV_const(tsv, len);
3720     }
3721 #   ifdef USE_ITHREADS
3722 #     ifdef HAS_CRYPT_R
3723     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3724       /* This should be threadsafe because in ithreads there is only
3725        * one thread per interpreter.  If this would not be true,
3726        * we would need a mutex to protect this malloc. */
3727         PL_reentrant_buffer->_crypt_struct_buffer =
3728           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3729 #if defined(__GLIBC__) || defined(__EMX__)
3730         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3731             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3732             /* work around glibc-2.2.5 bug */
3733             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3734         }
3735 #endif
3736     }
3737 #     endif /* HAS_CRYPT_R */
3738 #   endif /* USE_ITHREADS */
3739 #   ifdef FCRYPT
3740     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3741 #   else
3742     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3743 #   endif
3744     SvUTF8_off(TARG);
3745     SETTARG;
3746     RETURN;
3747 #else
3748     DIE(aTHX_
3749       "The crypt() function is unimplemented due to excessive paranoia.");
3750 #endif
3751 }
3752
3753 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3754  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3755
3756
3757 /* also used for: pp_lcfirst() */
3758
3759 PP(pp_ucfirst)
3760 {
3761     /* Actually is both lcfirst() and ucfirst().  Only the first character
3762      * changes.  This means that possibly we can change in-place, ie., just
3763      * take the source and change that one character and store it back, but not
3764      * if read-only etc, or if the length changes */
3765
3766     dSP;
3767     SV *source = TOPs;
3768     STRLEN slen; /* slen is the byte length of the whole SV. */
3769     STRLEN need;
3770     SV *dest;
3771     bool inplace;   /* ? Convert first char only, in-place */
3772     bool doing_utf8 = FALSE;               /* ? using utf8 */
3773     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3774     const int op_type = PL_op->op_type;
3775     const U8 *s;
3776     U8 *d;
3777     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3778     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3779                      * stored as UTF-8 at s. */
3780     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3781                      * lowercased) character stored in tmpbuf.  May be either
3782                      * UTF-8 or not, but in either case is the number of bytes */
3783
3784     s = (const U8*)SvPV_const(source, slen);
3785
3786     /* We may be able to get away with changing only the first character, in
3787      * place, but not if read-only, etc.  Later we may discover more reasons to
3788      * not convert in-place. */
3789     inplace = !SvREADONLY(source) && SvPADTMP(source);
3790
3791     /* First calculate what the changed first character should be.  This affects
3792      * whether we can just swap it out, leaving the rest of the string unchanged,
3793      * or even if have to convert the dest to UTF-8 when the source isn't */
3794
3795     if (! slen) {   /* If empty */
3796         need = 1; /* still need a trailing NUL */
3797         ulen = 0;
3798     }
3799     else if (DO_UTF8(source)) { /* Is the source utf8? */
3800         doing_utf8 = TRUE;
3801         ulen = UTF8SKIP(s);
3802         if (op_type == OP_UCFIRST) {
3803 #ifdef USE_LOCALE_CTYPE
3804             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3805 #else
3806             _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3807 #endif
3808         }
3809         else {
3810 #ifdef USE_LOCALE_CTYPE
3811             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3812 #else
3813             _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3814 #endif
3815         }
3816
3817         /* we can't do in-place if the length changes.  */
3818         if (ulen != tculen) inplace = FALSE;
3819         need = slen + 1 - ulen + tculen;
3820     }
3821     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3822             * latin1 is treated as caseless.  Note that a locale takes
3823             * precedence */
3824         ulen = 1;       /* Original character is 1 byte */
3825         tculen = 1;     /* Most characters will require one byte, but this will
3826                          * need to be overridden for the tricky ones */
3827         need = slen + 1;
3828
3829         if (op_type == OP_LCFIRST) {
3830
3831             /* lower case the first letter: no trickiness for any character */
3832 #ifdef USE_LOCALE_CTYPE
3833             if (IN_LC_RUNTIME(LC_CTYPE)) {
3834                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3835                 *tmpbuf = toLOWER_LC(*s);
3836             }
3837             else
3838 #endif
3839             {
3840                 *tmpbuf = (IN_UNI_8_BIT)
3841                           ? toLOWER_LATIN1(*s)
3842                           : toLOWER(*s);
3843             }
3844         }
3845 #ifdef USE_LOCALE_CTYPE
3846         /* is ucfirst() */
3847         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3848             if (IN_UTF8_CTYPE_LOCALE) {
3849                 goto do_uni_rules;
3850             }
3851
3852             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3853             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3854                                               locales have upper and title case
3855                                               different */
3856         }
3857 #endif
3858         else if (! IN_UNI_8_BIT) {
3859             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3860                                          * on EBCDIC machines whatever the
3861                                          * native function does */
3862         }
3863         else {
3864             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3865              * UTF-8, which we treat as not in locale), and cased latin1 */
3866             UV title_ord;
3867 #ifdef USE_LOCALE_CTYPE
3868       do_uni_rules:
3869 #endif
3870
3871             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3872             if (tculen > 1) {
3873                 assert(tculen == 2);
3874
3875                 /* If the result is an upper Latin1-range character, it can
3876                  * still be represented in one byte, which is its ordinal */
3877                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3878                     *tmpbuf = (U8) title_ord;
3879                     tculen = 1;
3880                 }
3881                 else {
3882                     /* Otherwise it became more than one ASCII character (in
3883                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3884                      * beyond Latin1, so the number of bytes changed, so can't
3885                      * replace just the first character in place. */
3886                     inplace = FALSE;
3887
3888                     /* If the result won't fit in a byte, the entire result
3889                      * will have to be in UTF-8.  Assume worst case sizing in
3890                      * conversion. (all latin1 characters occupy at most two
3891                      * bytes in utf8) */
3892                     if (title_ord > 255) {
3893                         doing_utf8 = TRUE;
3894                         convert_source_to_utf8 = TRUE;
3895                         need = slen * 2 + 1;
3896
3897                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3898                          * (both) characters whose title case is above 255 is
3899                          * 2. */
3900                         ulen = 2;
3901                     }
3902                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3903                         need = slen + 1 + 1;
3904                     }
3905                 }
3906             }
3907         } /* End of use Unicode (Latin1) semantics */
3908     } /* End of changing the case of the first character */
3909
3910     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3911      * generate the result */
3912     if (inplace) {
3913
3914         /* We can convert in place.  This means we change just the first
3915          * character without disturbing the rest; no need to grow */
3916         dest = source;
3917         s = d = (U8*)SvPV_force_nomg(source, slen);
3918     } else {
3919         dTARGET;
3920
3921         dest = TARG;
3922
3923         /* Here, we can't convert in place; we earlier calculated how much
3924          * space we will need, so grow to accommodate that */
3925         SvUPGRADE(dest, SVt_PV);
3926         d = (U8*)SvGROW(dest, need);
3927         (void)SvPOK_only(dest);
3928
3929         SETs(dest);
3930     }
3931
3932     if (doing_utf8) {
3933         if (! inplace) {
3934             if (! convert_source_to_utf8) {
3935
3936                 /* Here  both source and dest are in UTF-8, but have to create
3937                  * the entire output.  We initialize the result to be the
3938                  * title/lower cased first character, and then append the rest
3939                  * of the string. */
3940                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3941                 if (slen > ulen) {
3942                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3943                 }
3944             }
3945             else {
3946                 const U8 *const send = s + slen;
3947
3948                 /* Here the dest needs to be in UTF-8, but the source isn't,
3949                  * except we earlier UTF-8'd the first character of the source
3950                  * into tmpbuf.  First put that into dest, and then append the
3951                  * rest of the source, converting it to UTF-8 as we go. */
3952
3953                 /* Assert tculen is 2 here because the only two characters that
3954                  * get to this part of the code have 2-byte UTF-8 equivalents */
3955                 *d++ = *tmpbuf;
3956                 *d++ = *(tmpbuf + 1);
3957                 s++;    /* We have just processed the 1st char */
3958
3959                 for (; s < send; s++) {
3960                     d = uvchr_to_utf8(d, *s);
3961                 }
3962                 *d = '\0';
3963                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3964             }
3965             SvUTF8_on(dest);
3966         }
3967         else {   /* in-place UTF-8.  Just overwrite the first character */
3968             Copy(tmpbuf, d, tculen, U8);
3969             SvCUR_set(dest, need - 1);
3970         }
3971
3972     }
3973     else {  /* Neither source nor dest are in or need to be UTF-8 */
3974         if (slen) {
3975             if (inplace) {  /* in-place, only need to change the 1st char */
3976                 *d = *tmpbuf;
3977             }
3978             else {      /* Not in-place */
3979
3980                 /* Copy the case-changed character(s) from tmpbuf */
3981                 Copy(tmpbuf, d, tculen, U8);
3982                 d += tculen - 1; /* Code below expects d to point to final
3983                                   * character stored */
3984             }
3985         }
3986         else {  /* empty source */
3987             /* See bug #39028: Don't taint if empty  */
3988             *d = *s;
3989         }
3990
3991         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3992          * the destination to retain that flag */
3993         if (SvUTF8(source) && ! IN_BYTES)
3994             SvUTF8_on(dest);
3995
3996         if (!inplace) { /* Finish the rest of the string, unchanged */
3997             /* This will copy the trailing NUL  */
3998             Copy(s + 1, d + 1, slen, U8);
3999             SvCUR_set(dest, need - 1);
4000         }
4001     }
4002 #ifdef USE_LOCALE_CTYPE
4003     if (IN_LC_RUNTIME(LC_CTYPE)) {
4004         TAINT;
4005         SvTAINTED_on(dest);
4006     }
4007 #endif
4008     if (dest != source && SvTAINTED(source))
4009         SvTAINT(dest);
4010     SvSETMAGIC(dest);
4011     return NORMAL;
4012 }
4013
4014 /* There's so much setup/teardown code common between uc and lc, I wonder if
4015    it would be worth merging the two, and just having a switch outside each
4016    of the three tight loops.  There is less and less commonality though */
4017 PP(pp_uc)
4018 {
4019     dSP;
4020     SV *source = TOPs;
4021     STRLEN len;
4022     STRLEN min;
4023     SV *dest;
4024     const U8 *s;
4025     U8 *d;
4026
4027     SvGETMAGIC(source);
4028
4029     if (   SvPADTMP(source)
4030         && !SvREADONLY(source) && SvPOK(source)
4031         && !DO_UTF8(source)
4032         && (
4033 #ifdef USE_LOCALE_CTYPE
4034             (IN_LC_RUNTIME(LC_CTYPE))
4035             ? ! IN_UTF8_CTYPE_LOCALE
4036             :
4037 #endif
4038               ! IN_UNI_8_BIT))
4039     {
4040
4041         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4042          * make the loop tight, so we overwrite the source with the dest before
4043          * looking at it, and we need to look at the original source
4044          * afterwards.  There would also need to be code added to handle
4045          * switching to not in-place in midstream if we run into characters
4046          * that change the length.  Since being in locale overrides UNI_8_BIT,
4047          * that latter becomes irrelevant in the above test; instead for
4048          * locale, the size can't normally change, except if the locale is a
4049          * UTF-8 one */
4050         dest = source;
4051         s = d = (U8*)SvPV_force_nomg(source, len);
4052         min = len + 1;
4053     } else {
4054         dTARGET;
4055
4056         dest = TARG;
4057
4058         s = (const U8*)SvPV_nomg_const(source, len);
4059         min = len + 1;
4060
4061         SvUPGRADE(dest, SVt_PV);
4062         d = (U8*)SvGROW(dest, min);
4063         (void)SvPOK_only(dest);
4064
4065         SETs(dest);
4066     }
4067
4068     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4069        to check DO_UTF8 again here.  */
4070
4071     if (DO_UTF8(source)) {
4072         const U8 *const send = s + len;
4073         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4074
4075         /* All occurrences of these are to be moved to follow any other marks.
4076          * This is context-dependent.  We may not be passed enough context to
4077          * move the iota subscript beyond all of them, but we do the best we can
4078          * with what we're given.  The result is always better than if we
4079          * hadn't done this.  And, the problem would only arise if we are
4080          * passed a character without all its combining marks, which would be
4081          * the caller's mistake.  The information this is based on comes from a
4082          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4083          * itself) and so can't be checked properly to see if it ever gets
4084          * revised.  But the likelihood of it changing is remote */
4085         bool in_iota_subscript = FALSE;
4086
4087         while (s < send) {
4088             STRLEN u;
4089             STRLEN ulen;
4090             UV uv;
4091             if (in_iota_subscript && ! _is_utf8_mark(s)) {
4092
4093                 /* A non-mark.  Time to output the iota subscript */
4094                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4095                 d += capital_iota_len;
4096                 in_iota_subscript = FALSE;
4097             }
4098
4099             /* Then handle the current character.  Get the changed case value
4100              * and copy it to the output buffer */
4101
4102             u = UTF8SKIP(s);
4103 #ifdef USE_LOCALE_CTYPE
4104             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4105 #else
4106             uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4107 #endif
4108 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4109 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4110             if (uv == GREEK_CAPITAL_LETTER_IOTA
4111                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4112             {
4113                 in_iota_subscript = TRUE;
4114             }
4115             else {
4116                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4117                     /* If the eventually required minimum size outgrows the
4118                      * available space, we need to grow. */
4119                     const UV o = d - (U8*)SvPVX_const(dest);
4120
4121                     /* If someone uppercases one million U+03B0s we SvGROW()
4122                      * one million times.  Or we could try guessing how much to
4123                      * allocate without allocating too much.  Such is life.
4124                      * See corresponding comment in lc code for another option
4125                      * */
4126                     d = o + (U8*) SvGROW(dest, min);
4127                 }
4128                 Copy(tmpbuf, d, ulen, U8);
4129                 d += ulen;
4130             }
4131             s += u;
4132         }
4133         if (in_iota_subscript) {
4134             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4135             d += capital_iota_len;
4136         }
4137         SvUTF8_on(dest);
4138         *d = '\0';
4139
4140         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4141     }
4142     else {      /* Not UTF-8 */
4143         if (len) {
4144             const U8 *const send = s + len;
4145
4146             /* Use locale casing if in locale; regular style if not treating
4147              * latin1 as having case; otherwise the latin1 casing.  Do the
4148              * whole thing in a tight loop, for speed, */
4149 #ifdef USE_LOCALE_CTYPE
4150             if (IN_LC_RUNTIME(LC_CTYPE)) {
4151                 if (IN_UTF8_CTYPE_LOCALE) {
4152                     goto do_uni_rules;
4153                 }
4154                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4155                 for (; s < send; d++, s++)
4156                     *d = (U8) toUPPER_LC(*s);
4157             }
4158             else
4159 #endif
4160                  if (! IN_UNI_8_BIT) {
4161                 for (; s < send; d++, s++) {
4162                     *d = toUPPER(*s);
4163                 }
4164             }
4165             else {
4166 #ifdef USE_LOCALE_CTYPE
4167           do_uni_rules:
4168 #endif
4169                 for (; s < send; d++, s++) {
4170                     *d = toUPPER_LATIN1_MOD(*s);
4171                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4172                         continue;
4173                     }
4174
4175                     /* The mainstream case is the tight loop above.  To avoid
4176                      * extra tests in that, all three characters that require
4177                      * special handling are mapped by the MOD to the one tested
4178                      * just above.
4179                      * Use the source to distinguish between the three cases */
4180
4181 #if    UNICODE_MAJOR_VERSION > 2                                        \
4182    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4183                                   && UNICODE_DOT_DOT_VERSION >= 8)
4184                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4185
4186                         /* uc() of this requires 2 characters, but they are
4187                          * ASCII.  If not enough room, grow the string */
4188                         if (SvLEN(dest) < ++min) {
4189                             const UV o = d - (U8*)SvPVX_const(dest);
4190                             d = o + (U8*) SvGROW(dest, min);
4191                         }
4192                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4193                         continue;   /* Back to the tight loop; still in ASCII */
4194                     }
4195 #endif
4196
4197                     /* The other two special handling characters have their
4198                      * upper cases outside the latin1 range, hence need to be
4199                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4200                      * here we are somewhere in the middle of processing a
4201                      * non-UTF-8 string, and realize that we will have to convert
4202                      * the whole thing to UTF-8.  What to do?  There are
4203                      * several possibilities.  The simplest to code is to
4204                      * convert what we have so far, set a flag, and continue on
4205                      * in the loop.  The flag would be tested each time through
4206                      * the loop, and if set, the next character would be
4207                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4208                      * to slow down the mainstream case at all for this fairly
4209                      * rare case, so I didn't want to add a test that didn't
4210                      * absolutely have to be there in the loop, besides the
4211                      * possibility that it would get too complicated for
4212                      * optimizers to deal with.  Another possibility is to just
4213                      * give up, convert the source to UTF-8, and restart the
4214                      * function that way.  Another possibility is to convert
4215                      * both what has already been processed and what is yet to
4216                      * come separately to UTF-8, then jump into the loop that
4217                      * handles UTF-8.  But the most efficient time-wise of the
4218                      * ones I could think of is what follows, and turned out to
4219                      * not require much extra code.  */
4220
4221                     /* Convert what we have so far into UTF-8, telling the
4222                      * function that we know it should be converted, and to
4223                      * allow extra space for what we haven't processed yet.
4224                      * Assume the worst case space requirements for converting
4225                      * what we haven't processed so far: that it will require
4226                      * two bytes for each remaining source character, plus the
4227                      * NUL at the end.  This may cause the string pointer to
4228                      * move, so re-find it. */
4229
4230                     len = d - (U8*)SvPVX_const(dest);
4231                     SvCUR_set(dest, len);
4232                     len = sv_utf8_upgrade_flags_grow(dest,
4233                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4234                                                 (send -s) * 2 + 1);
4235                     d = (U8*)SvPVX(dest) + len;
4236
4237                     /* Now process the remainder of the source, converting to
4238                      * upper and UTF-8.  If a resulting byte is invariant in
4239                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4240                      * append it to the output. */
4241                     for (; s < send; s++) {
4242                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4243                         d += len;
4244                     }
4245
4246                     /* Here have processed the whole source; no need to continue
4247                      * with the outer loop.  Each character has been converted
4248                      * to upper case and converted to UTF-8 */
4249
4250                     break;
4251                 } /* End of processing all latin1-style chars */
4252             } /* End of processing all chars */
4253         } /* End of source is not empty */
4254
4255         if (source != dest) {
4256             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4257             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4258         }
4259     } /* End of isn't utf8 */
4260 #ifdef USE_LOCALE_CTYPE
4261     if (IN_LC_RUNTIME(LC_CTYPE)) {
4262         TAINT;
4263         SvTAINTED_on(dest);
4264     }
4265 #endif
4266     if (dest != source && SvTAINTED(source))
4267         SvTAINT(dest);
4268     SvSETMAGIC(dest);
4269     return NORMAL;
4270 }
4271
4272 PP(pp_lc)
4273 {
4274     dSP;
4275     SV *source = TOPs;
4276     STRLEN len;
4277     STRLEN min;
4278     SV *dest;
4279     const U8 *s;
4280     U8 *d;
4281
4282     SvGETMAGIC(source);
4283
4284     if (   SvPADTMP(source)
4285         && !SvREADONLY(source) && SvPOK(source)
4286         && !DO_UTF8(source)) {
4287
4288         /* We can convert in place, as lowercasing anything in the latin1 range
4289          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4290         dest = source;
4291         s = d = (U8*)SvPV_force_nomg(source, len);
4292         min = len + 1;
4293     } else {
4294         dTARGET;
4295
4296         dest = TARG;
4297
4298         s = (const U8*)SvPV_nomg_const(source, len);
4299         min = len + 1;
4300
4301         SvUPGRADE(dest, SVt_PV);
4302         d = (U8*)SvGROW(dest, min);
4303         (void)SvPOK_only(dest);
4304
4305         SETs(dest);
4306     }
4307
4308     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4309        to check DO_UTF8 again here.  */
4310
4311     if (DO_UTF8(source)) {
4312         const U8 *const send = s + len;
4313         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4314
4315         while (s < send) {
4316             const STRLEN u = UTF8SKIP(s);
4317             STRLEN ulen;
4318
4319 #ifdef USE_LOCALE_CTYPE
4320             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4321 #else
4322             _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4323 #endif
4324
4325             /* Here is where we would do context-sensitive actions.  See the
4326              * commit message for 86510fb15 for why there isn't any */
4327
4328             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4329
4330                 /* If the eventually required minimum size outgrows the
4331                  * available space, we need to grow. */
4332                 const UV o = d - (U8*)SvPVX_const(dest);
4333
4334                 /* If someone lowercases one million U+0130s we SvGROW() one
4335                  * million times.  Or we could try guessing how much to
4336                  * allocate without allocating too much.  Such is life.
4337                  * Another option would be to grow an extra byte or two more
4338                  * each time we need to grow, which would cut down the million
4339                  * to 500K, with little waste */
4340                 d = o + (U8*) SvGROW(dest, min);
4341             }
4342
4343             /* Copy the newly lowercased letter to the output buffer we're
4344              * building */
4345             Copy(tmpbuf, d, ulen, U8);
4346             d += ulen;
4347             s += u;
4348         }   /* End of looping through the source string */
4349         SvUTF8_on(dest);
4350         *d = '\0';
4351         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4352     } else {    /* Not utf8 */
4353         if (len) {
4354             const U8 *const send = s + len;
4355
4356             /* Use locale casing if in locale; regular style if not treating
4357              * latin1 as having case; otherwise the latin1 casing.  Do the
4358              * whole thing in a tight loop, for speed, */
4359 #ifdef USE_LOCALE_CTYPE
4360             if (IN_LC_RUNTIME(LC_CTYPE)) {
4361                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4362                 for (; s < send; d++, s++)
4363                     *d = toLOWER_LC(*s);
4364             }
4365             else
4366 #endif
4367             if (! IN_UNI_8_BIT) {
4368                 for (; s < send; d++, s++) {
4369                     *d = toLOWER(*s);
4370                 }
4371             }
4372             else {
4373                 for (; s < send; d++, s++) {
4374                     *d = toLOWER_LATIN1(*s);
4375                 }
4376             }
4377         }
4378         if (source != dest) {
4379             *d = '\0';
4380             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4381         }
4382     }
4383 #ifdef USE_LOCALE_CTYPE
4384     if (IN_LC_RUNTIME(LC_CTYPE)) {
4385         TAINT;
4386         SvTAINTED_on(dest);
4387     }
4388 #endif
4389     if (dest != source && SvTAINTED(source))
4390         SvTAINT(dest);
4391     SvSETMAGIC(dest);
4392     return NORMAL;
4393 }
4394
4395 PP(pp_quotemeta)
4396 {
4397     dSP; dTARGET;
4398     SV * const sv = TOPs;
4399     STRLEN len;
4400     const char *s = SvPV_const(sv,len);
4401
4402     SvUTF8_off(TARG);                           /* decontaminate */
4403     if (len) {
4404         char *d;
4405         SvUPGRADE(TARG, SVt_PV);
4406         SvGROW(TARG, (len * 2) + 1);
4407         d = SvPVX(TARG);
4408         if (DO_UTF8(sv)) {
4409             while (len) {
4410                 STRLEN ulen = UTF8SKIP(s);
4411                 bool to_quote = FALSE;
4412
4413                 if (UTF8_IS_INVARIANT(*s)) {
4414                     if (_isQUOTEMETA(*s)) {
4415                         to_quote = TRUE;
4416                     }
4417                 }
4418                 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4419                     if (
4420 #ifdef USE_LOCALE_CTYPE
4421                     /* In locale, we quote all non-ASCII Latin1 chars.
4422                      * Otherwise use the quoting rules */
4423
4424                     IN_LC_RUNTIME(LC_CTYPE)
4425                         ||
4426 #endif
4427                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4428                     {
4429                         to_quote = TRUE;
4430                     }
4431                 }
4432                 else if (is_QUOTEMETA_high(s)) {
4433                     to_quote = TRUE;
4434                 }
4435
4436                 if (to_quote) {
4437                     *d++ = '\\';
4438                 }
4439                 if (ulen > len)
4440                     ulen = len;
4441                 len -= ulen;
4442                 while (ulen--)
4443                     *d++ = *s++;
4444             }
4445             SvUTF8_on(TARG);
4446         }
4447         else if (IN_UNI_8_BIT) {
4448             while (len--) {
4449                 if (_isQUOTEMETA(*s))
4450                     *d++ = '\\';
4451                 *d++ = *s++;
4452             }
4453         }
4454         else {
4455             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4456              * including everything above ASCII */
4457             while (len--) {
4458                 if (!isWORDCHAR_A(*s))
4459                     *d++ = '\\';
4460                 *d++ = *s++;
4461             }
4462         }
4463         *d = '\0';
4464         SvCUR_set(TARG, d - SvPVX_const(TARG));
4465         (void)SvPOK_only_UTF8(TARG);
4466     }
4467     else
4468         sv_setpvn(TARG, s, len);
4469     SETTARG;
4470     return NORMAL;
4471 }
4472
4473 PP(pp_fc)
4474 {
4475     dTARGET;
4476     dSP;
4477     SV *source = TOPs;
4478     STRLEN len;
4479     STRLEN min;
4480     SV *dest;
4481     const U8 *s;
4482     const U8 *send;
4483     U8 *d;
4484     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4485 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4486    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4487                                       || UNICODE_DOT_DOT_VERSION > 0)
4488     const bool full_folding = TRUE; /* This variable is here so we can easily
4489                                        move to more generality later */
4490 #else
4491     const bool full_folding = FALSE;
4492 #endif
4493     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4494 #ifdef USE_LOCALE_CTYPE
4495                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4496 #endif
4497     ;
4498
4499     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4500      * You are welcome(?) -Hugmeir
4501      */
4502
4503     SvGETMAGIC(source);
4504
4505     dest = TARG;
4506
4507     if (SvOK(source)) {
4508         s = (const U8*)SvPV_nomg_const(source, len);
4509     } else {
4510         if (ckWARN(WARN_UNINITIALIZED))
4511             report_uninit(source);
4512         s = (const U8*)"";
4513         len = 0;
4514     }
4515
4516     min = len + 1;
4517
4518     SvUPGRADE(dest, SVt_PV);
4519     d = (U8*)SvGROW(dest, min);
4520     (void)SvPOK_only(dest);
4521
4522     SETs(dest);
4523
4524     send = s + len;
4525     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4526         while (s < send) {
4527             const STRLEN u = UTF8SKIP(s);
4528             STRLEN ulen;
4529
4530             _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4531
4532             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4533                 const UV o = d - (U8*)SvPVX_const(dest);
4534                 d = o + (U8*) SvGROW(dest, min);
4535             }
4536
4537             Copy(tmpbuf, d, ulen, U8);
4538             d += ulen;
4539             s += u;
4540         }
4541         SvUTF8_on(dest);
4542     } /* Unflagged string */
4543     else if (len) {
4544 #ifdef USE_LOCALE_CTYPE
4545         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4546             if (IN_UTF8_CTYPE_LOCALE) {
4547                 goto do_uni_folding;
4548             }
4549             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4550             for (; s < send; d++, s++)
4551                 *d = (U8) toFOLD_LC(*s);
4552         }
4553         else
4554 #endif
4555         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4556             for (; s < send; d++, s++)
4557                 *d = toFOLD(*s);
4558         }
4559         else {
4560 #ifdef USE_LOCALE_CTYPE
4561       do_uni_folding:
4562 #endif
4563             /* For ASCII and the Latin-1 range, there's only two troublesome
4564              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4565              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4566              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4567              * For the rest, the casefold is their lowercase.  */
4568             for (; s < send; d++, s++) {
4569                 if (*s == MICRO_SIGN) {
4570                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4571                      * which is outside of the latin-1 range. There's a couple
4572                      * of ways to deal with this -- khw discusses them in
4573                      * pp_lc/uc, so go there :) What we do here is upgrade what
4574                      * we had already casefolded, then enter an inner loop that
4575                      * appends the rest of the characters as UTF-8. */
4576                     len = d - (U8*)SvPVX_const(dest);
4577                     SvCUR_set(dest, len);
4578                     len = sv_utf8_upgrade_flags_grow(dest,
4579                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4580                                                 /* The max expansion for latin1
4581                                                  * chars is 1 byte becomes 2 */
4582                                                 (send -s) * 2 + 1);
4583                     d = (U8*)SvPVX(dest) + len;
4584
4585                     Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4586                     d += small_mu_len;
4587                     s++;
4588                     for (; s < send; s++) {
4589                         STRLEN ulen;
4590                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4591                         if UVCHR_IS_INVARIANT(fc) {
4592                             if (full_folding
4593                                 && *s == LATIN_SMALL_LETTER_SHARP_S)
4594                             {
4595                                 *d++ = 's';
4596                                 *d++ = 's';
4597                             }
4598                             else
4599                                 *d++ = (U8)fc;
4600                         }
4601                         else {
4602                             Copy(tmpbuf, d, ulen, U8);
4603                             d += ulen;
4604                         }
4605                     }
4606                     break;
4607                 }
4608                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4609                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4610                      * becomes "ss", which may require growing the SV. */
4611                     if (SvLEN(dest) < ++min) {
4612                         const UV o = d - (U8*)SvPVX_const(dest);
4613                         d = o + (U8*) SvGROW(dest, min);
4614                      }
4615                     *(d)++ = 's';
4616                     *d = 's';
4617                 }
4618                 else { /* If it's not one of those two, the fold is their lower
4619                           case */
4620                     *d = toLOWER_LATIN1(*s);
4621                 }
4622              }
4623         }
4624     }
4625     *d = '\0';
4626     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4627
4628 #ifdef USE_LOCALE_CTYPE
4629     if (IN_LC_RUNTIME(LC_CTYPE)) {
4630         TAINT;
4631         SvTAINTED_on(dest);
4632     }
4633 #endif
4634     if (SvTAINTED(source))
4635         SvTAINT(dest);
4636     SvSETMAGIC(dest);
4637     RETURN;
4638 }
4639
4640 /* Arrays. */
4641
4642 PP(pp_aslice)
4643 {
4644     dSP; dMARK; dORIGMARK;
4645     AV *const av = MUTABLE_AV(POPs);
4646     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4647
4648     if (SvTYPE(av) == SVt_PVAV) {
4649         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4650         bool can_preserve = FALSE;
4651
4652         if (localizing) {
4653             MAGIC *mg;
4654             HV *stash;
4655
4656             can_preserve = SvCANEXISTDELETE(av);
4657         }
4658
4659         if (lval && localizing) {
4660             SV **svp;
4661             SSize_t max = -1;
4662             for (svp = MARK + 1; svp <= SP; svp++) {
4663                 const SSize_t elem = SvIV(*svp);
4664                 if (elem > max)
4665                     max = elem;
4666             }
4667             if (max > AvMAX(av))
4668                 av_extend(av, max);
4669         }
4670
4671         while (++MARK <= SP) {
4672             SV **svp;
4673             SSize_t elem = SvIV(*MARK);
4674             bool preeminent = TRUE;
4675
4676             if (localizing && can_preserve) {
4677                 /* If we can determine whether the element exist,
4678                  * Try to preserve the existenceness of a tied array
4679                  * element by using EXISTS and DELETE if possible.
4680                  * Fallback to FETCH and STORE otherwise. */
4681                 preeminent = av_exists(av, elem);
4682             }
4683
4684             svp = av_fetch(av, elem, lval);
4685             if (lval) {
4686                 if (!svp || !*svp)
4687                     DIE(aTHX_ PL_no_aelem, elem);
4688                 if (localizing) {
4689                     if (preeminent)
4690                         save_aelem(av, elem, svp);
4691                     else
4692                         SAVEADELETE(av, elem);
4693                 }
4694             }
4695             *MARK = svp ? *svp : &PL_sv_undef;
4696         }
4697     }
4698     if (GIMME_V != G_ARRAY) {
4699         MARK = ORIGMARK;
4700         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4701         SP = MARK;
4702     }
4703     RETURN;
4704 }
4705
4706 PP(pp_kvaslice)
4707 {
4708     dSP; dMARK;
4709     AV *const av = MUTABLE_AV(POPs);
4710     I32 lval = (PL_op->op_flags & OPf_MOD);
4711     SSize_t items = SP - MARK;
4712
4713     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4714        const I32 flags = is_lvalue_sub();
4715        if (flags) {
4716            if (!(flags & OPpENTERSUB_INARGS))
4717                /* diag_listed_as: Can't modify %s in %s */
4718                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4719            lval = flags;
4720        }
4721     }
4722
4723     MEXTEND(SP,items);
4724     while (items > 1) {
4725         *(MARK+items*2-1) = *(MARK+items);
4726         items--;
4727     }
4728     items = SP-MARK;
4729     SP += items;
4730
4731     while (++MARK <= SP) {
4732         SV **svp;
4733
4734         svp = av_fetch(av, SvIV(*MARK), lval);
4735         if (lval) {
4736             if (!svp || !*svp || *svp == &PL_sv_undef) {
4737                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4738             }
4739             *MARK = sv_mortalcopy(*MARK);
4740         }
4741         *++MARK = svp ? *svp : &PL_sv_undef;
4742     }
4743     if (GIMME_V != G_ARRAY) {
4744         MARK = SP - items*2;
4745         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4746         SP = MARK;
4747     }
4748     RETURN;
4749 }
4750
4751
4752 PP(pp_aeach)
4753 {
4754     dSP;
4755     AV *array = MUTABLE_AV(POPs);
4756     const U8 gimme = GIMME_V;
4757     IV *iterp = Perl_av_iter_p(aTHX_ array);
4758     const IV current = (*iterp)++;
4759
4760     if (current > av_tindex(array)) {
4761         *iterp = 0;
4762         if (gimme == G_SCALAR)
4763             RETPUSHUNDEF;
4764         else
4765             RETURN;
4766     }
4767
4768     EXTEND(SP, 2);
4769     mPUSHi(current);
4770     if (gimme == G_ARRAY) {
4771         SV **const element = av_fetch(array, current, 0);
4772         PUSHs(element ? *element : &PL_sv_undef);
4773     }
4774     RETURN;
4775 }
4776
4777 /* also used for: pp_avalues()*/
4778 PP(pp_akeys)
4779 {
4780     dSP;
4781     AV *array = MUTABLE_AV(POPs);
4782     const U8 gimme = GIMME_V;
4783
4784     *Perl_av_iter_p(aTHX_ array) = 0;
4785
4786     if (gimme == G_SCALAR) {
4787         dTARGET;
4788         PUSHi(av_tindex(array) + 1);
4789     }
4790     else if (gimme == G_ARRAY) {
4791       if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
4792         const I32 flags = is_lvalue_sub();
4793         if (flags && !(flags & OPpENTERSUB_INARGS))
4794             /* diag_listed_as: Can't modify %s in %s */
4795             Perl_croak(aTHX_
4796                       "Can't modify keys on array in list assignment");
4797       }
4798       {
4799         IV n = Perl_av_len(aTHX_ array);
4800         IV i;
4801
4802         EXTEND(SP, n + 1);
4803
4804         if (  PL_op->op_type == OP_AKEYS
4805            || (  PL_op->op_type == OP_AVHVSWITCH
4806               && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS  ))
4807         {
4808             for (i = 0;  i <= n;  i++) {
4809                 mPUSHi(i);
4810             }
4811         }
4812         else {
4813             for (i = 0;  i <= n;  i++) {
4814                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4815                 PUSHs(elem ? *elem : &PL_sv_undef);
4816             }
4817         }
4818       }
4819     }
4820     RETURN;
4821 }
4822
4823 /* Associative arrays. */
4824
4825 PP(pp_each)
4826 {
4827     dSP;
4828     HV * hash = MUTABLE_HV(POPs);
4829     HE *entry;
4830     const U8 gimme = GIMME_V;
4831
4832     entry = hv_iternext(hash);
4833
4834     EXTEND(SP, 2);
4835     if (entry) {
4836         SV* const sv = hv_iterkeysv(entry);
4837         PUSHs(sv);
4838         if (gimme == G_ARRAY) {
4839             SV *val;
4840             val = hv_iterval(hash, entry);
4841             PUSHs(val);
4842         }
4843     }
4844     else if (gimme == G_SCALAR)
4845         RETPUSHUNDEF;
4846
4847     RETURN;
4848 }
4849
4850 STATIC OP *
4851 S_do_delete_local(pTHX)
4852 {
4853     dSP;
4854     const U8 gimme = GIMME_V;
4855     const MAGIC *mg;
4856     HV *stash;
4857     const bool sliced = !!(PL_op->op_private & OPpSLICE);
4858     SV **unsliced_keysv = sliced ? NULL : sp--;
4859     SV * const osv = POPs;
4860     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4861     dORIGMARK;
4862     const bool tied = SvRMAGICAL(osv)
4863                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4864     const bool can_preserve = SvCANEXISTDELETE(osv);
4865     const U32 type = SvTYPE(osv);
4866     SV ** const end = sliced ? SP : unsliced_keysv;
4867
4868     if (type == SVt_PVHV) {                     /* hash element */
4869             HV * const hv = MUTABLE_HV(osv);
4870             while (++MARK <= end) {
4871                 SV * const keysv = *MARK;
4872                 SV *sv = NULL;
4873                 bool preeminent = TRUE;
4874                 if (can_preserve)
4875                     preeminent = hv_exists_ent(hv, keysv, 0);
4876                 if (tied) {
4877                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4878                     if (he)
4879                         sv = HeVAL(he);
4880                     else
4881                         preeminent = FALSE;
4882                 }
4883                 else {
4884                     sv = hv_delete_ent(hv, keysv, 0, 0);
4885                     if (preeminent)
4886                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4887                 }
4888                 if (preeminent) {
4889                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4890                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4891                     if (tied) {
4892                         *MARK = sv_mortalcopy(sv);
4893                         mg_clear(sv);
4894                     } else
4895                         *MARK = sv;
4896                 }
4897                 else {
4898                     SAVEHDELETE(hv, keysv);
4899                     *MARK = &PL_sv_undef;
4900                 }
4901             }
4902     }
4903     else if (type == SVt_PVAV) {                  /* array element */
4904             if (PL_op->op_flags & OPf_SPECIAL) {
4905                 AV * const av = MUTABLE_AV(osv);
4906                 while (++MARK <= end) {
4907                     SSize_t idx = SvIV(*MARK);
4908                     SV *sv = NULL;
4909                     bool preeminent = TRUE;
4910                     if (can_preserve)
4911                         preeminent = av_exists(av, idx);
4912                     if (tied) {
4913                         SV **svp = av_fetch(av, idx, 1);
4914                         if (svp)
4915                             sv = *svp;
4916                         else
4917                             preeminent = FALSE;
4918                     }
4919                     else {
4920                         sv = av_delete(av, idx, 0);
4921                         if (preeminent)
4922                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4923                     }
4924                     if (preeminent) {
4925                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4926                         if (tied) {
4927                             *MARK = sv_mortalcopy(sv);
4928                             mg_clear(sv);
4929                         } else
4930                             *MARK = sv;
4931                     }
4932                     else {
4933                         SAVEADELETE(av, idx);
4934                         *MARK = &PL_sv_undef;
4935                     }
4936                 }
4937             }
4938             else
4939                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4940     }
4941     else
4942             DIE(aTHX_ "Not a HASH reference");
4943     if (sliced) {
4944         if (gimme == G_VOID)
4945             SP = ORIGMARK;
4946         else if (gimme == G_SCALAR) {
4947             MARK = ORIGMARK;
4948             if (SP > MARK)
4949                 *++MARK = *SP;
4950             else
4951                 *++MARK = &PL_sv_undef;
4952             SP = MARK;
4953         }
4954     }
4955     else if (gimme != G_VOID)
4956         PUSHs(*unsliced_keysv);
4957
4958     RETURN;
4959 }
4960
4961 PP(pp_delete)
4962 {
4963     dSP;
4964     U8 gimme;
4965     I32 discard;
4966
4967     if (PL_op->op_private & OPpLVAL_INTRO)
4968         return do_delete_local();
4969
4970     gimme = GIMME_V;
4971     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4972
4973     if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
4974         dMARK; dORIGMARK;
4975         HV * const hv = MUTABLE_HV(POPs);
4976         const U32 hvtype = SvTYPE(hv);
4977         int skip = 0;
4978         if (PL_op->op_private & OPpKVSLICE) {
4979             SSize_t items = SP - MARK;
4980
4981             MEXTEND(SP,items);
4982             while (items > 1) {
4983                 *(MARK+items*2-1) = *(MARK+items);
4984                 items--;
4985             }
4986             items = SP - MARK;
4987             SP += items;
4988             skip = 1;
4989         }
4990         if (hvtype == SVt_PVHV) {                       /* hash element */
4991             while ((MARK += (1+skip)) <= SP) {
4992                 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
4993                 *MARK = sv ? sv : &PL_sv_undef;
4994             }
4995         }
4996         else if (hvtype == SVt_PVAV) {                  /* array element */
4997             if (PL_op->op_flags & OPf_SPECIAL) {
4998                 while ((MARK += (1+skip)) <= SP) {
4999                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5000                     *MARK = sv ? sv : &PL_sv_undef;
5001                 }
5002             }
5003         }
5004         else
5005             DIE(aTHX_ "Not a HASH reference");
5006         if (discard)
5007             SP = ORIGMARK;
5008         else if (gimme == G_SCALAR) {
5009             MARK = ORIGMARK;
5010             if (SP > MARK)
5011                 *++MARK = *SP;
5012             else
5013                 *++MARK = &PL_sv_undef;
5014             SP = MARK;
5015         }
5016     }
5017     else {
5018         SV *keysv = POPs;
5019         HV * const hv = MUTABLE_HV(POPs);
5020         SV *sv = NULL;
5021         if (SvTYPE(hv) == SVt_PVHV)
5022             sv = hv_delete_ent(hv, keysv, discard, 0);
5023         else if (SvTYPE(hv) == SVt_PVAV) {
5024             if (PL_op->op_flags & OPf_SPECIAL)
5025                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5026             else
5027                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5028         }
5029         else
5030             DIE(aTHX_ "Not a HASH reference");
5031         if (!sv)
5032             sv = &PL_sv_undef;
5033         if (!discard)
5034             PUSHs(sv);
5035     }
5036     RETURN;
5037 }
5038
5039 PP(pp_exists)
5040 {
5041     dSP;
5042     SV *tmpsv;
5043     HV *hv;
5044
5045     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5046         GV *gv;
5047         SV * const sv = POPs;
5048         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5049         if (cv)
5050             RETPUSHYES;
5051         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5052             RETPUSHYES;
5053         RETPUSHNO;
5054     }
5055     tmpsv = POPs;
5056     hv = MUTABLE_HV(POPs);
5057     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5058         if (hv_exists_ent(hv, tmpsv, 0))
5059             RETPUSHYES;
5060     }
5061     else if (SvTYPE(hv) == SVt_PVAV) {
5062         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
5063             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5064                 RETPUSHYES;
5065         }
5066     }
5067     else {
5068         DIE(aTHX_ "Not a HASH reference");
5069     }
5070     RETPUSHNO;
5071 }
5072
5073 PP(pp_hslice)
5074 {
5075     dSP; dMARK; dORIGMARK;
5076     HV * const hv = MUTABLE_HV(POPs);
5077     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5078     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5079     bool can_preserve = FALSE;
5080
5081     if (localizing) {
5082         MAGIC *mg;
5083         HV *stash;
5084
5085         if (SvCANEXISTDELETE(hv))
5086             can_preserve = TRUE;
5087     }
5088
5089     while (++MARK <= SP) {
5090         SV * const keysv = *MARK;
5091         SV **svp;
5092         HE *he;
5093         bool preeminent = TRUE;
5094
5095         if (localizing && can_preserve) {
5096             /* If we can determine whether the element exist,
5097              * try to preserve the existenceness of a tied hash
5098              * element by using EXISTS and DELETE if possible.
5099              * Fallback to FETCH and STORE otherwise. */
5100             preeminent = hv_exists_ent(hv, keysv, 0);
5101         }
5102
5103         he = hv_fetch_ent(hv, keysv, lval, 0);
5104         svp = he ? &HeVAL(he) : NULL;
5105
5106         if (lval) {
5107             if (!svp || !*svp || *svp == &PL_sv_undef) {
5108                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5109             }
5110             if (localizing) {
5111                 if (HvNAME_get(hv) && isGV(*svp))
5112                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5113                 else if (preeminent)
5114                     save_helem_flags(hv, keysv, svp,
5115                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5116                 else
5117                     SAVEHDELETE(hv, keysv);
5118             }
5119         }
5120         *MARK = svp && *svp ? *svp : &PL_sv_undef;
5121     }
5122     if (GIMME_V != G_ARRAY) {
5123         MARK = ORIGMARK;
5124         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5125         SP = MARK;
5126     }
5127     RETURN;
5128 }
5129
5130 PP(pp_kvhslice)
5131 {
5132     dSP; dMARK;
5133     HV * const hv = MUTABLE_HV(POPs);
5134     I32 lval = (PL_op->op_flags & OPf_MOD);
5135     SSize_t items = SP - MARK;
5136
5137     if (PL_op->op_private & OPpMAYBE_LVSUB) {
5138        const I32 flags = is_lvalue_sub();
5139        if (flags) {
5140            if (!(flags & OPpENTERSUB_INARGS))
5141                /* diag_listed_as: Can't modify %s in %s */
5142                Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5143                                  GIMME_V == G_ARRAY ? "list" : "scalar");
5144            lval = flags;
5145        }
5146     }
5147
5148     MEXTEND(SP,items);
5149     while (items > 1) {
5150         *(MARK+items*2-1) = *(MARK+items);
5151         items--;
5152     }
5153     items = SP-MARK;
5154     SP += items;
5155
5156     while (++MARK <= SP) {
5157         SV * const keysv = *MARK;
5158         SV **svp;
5159         HE *he;
5160
5161         he = hv_fetch_ent(hv, keysv, lval, 0);
5162         svp = he ? &HeVAL(he) : NULL;
5163
5164         if (lval) {
5165             if (!svp || !*svp || *svp == &PL_sv_undef) {
5166                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5167             }
5168             *MARK = sv_mortalcopy(*MARK);
5169         }
5170         *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5171     }
5172     if (GIMME_V != G_ARRAY) {
5173         MARK = SP - items*2;
5174         *++MARK = items > 0 ? *SP : &PL_sv_undef;
5175         SP = MARK;
5176     }
5177     RETURN;
5178 }
5179
5180 /* List operators. */
5181
5182 PP(pp_list)
5183 {
5184     I32 markidx = POPMARK;
5185     if (GIMME_V != G_ARRAY) {
5186         SV **mark = PL_stack_base + markidx;
5187         dSP;
5188         if (++MARK <= SP)
5189             *MARK = *SP;                /* unwanted list, return last item */
5190         else
5191             *MARK = &PL_sv_undef;
5192         SP = MARK;
5193         PUTBACK;
5194     }
5195     return NORMAL;
5196 }
5197
5198 PP(pp_lslice)
5199 {
5200     dSP;
5201     SV ** const lastrelem = PL_stack_sp;
5202     SV ** const lastlelem = PL_stack_base + POPMARK;
5203     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5204     SV ** const firstrelem = lastlelem + 1;
5205     const U8 mod = PL_op->op_flags & OPf_MOD;
5206
5207     const I32 max = lastrelem - lastlelem;
5208     SV **lelem;
5209
5210     if (GIMME_V != G_ARRAY) {
5211         if (lastlelem < firstlelem) {
5212             EXTEND(SP, 1);
5213             *firstlelem = &PL_sv_undef;
5214         }
5215         else {
5216             I32 ix = SvIV(*lastlelem);
5217             if (ix < 0)
5218                 ix += max;
5219             if (ix < 0 || ix >= max)
5220                 *firstlelem = &PL_sv_undef;
5221             else
5222                 *firstlelem = firstrelem[ix];
5223         }
5224         SP = firstlelem;
5225         RETURN;
5226     }
5227
5228     if (max == 0) {
5229         SP = firstlelem - 1;
5230         RETURN;
5231     }
5232
5233     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5234         I32 ix = SvIV(*lelem);
5235         if (ix < 0)
5236             ix += max;
5237         if (ix < 0 || ix >= max)
5238             *lelem = &PL_sv_undef;
5239         else {
5240             if (!(*lelem = firstrelem[ix]))
5241                 *lelem = &PL_sv_undef;
5242             else if (mod && SvPADTMP(*lelem)) {
5243                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5244             }
5245         }
5246     }
5247     SP = lastlelem;
5248     RETURN;
5249 }
5250
5251 PP(pp_anonlist)
5252 {
5253     dSP; dMARK;
5254     const I32 items = SP - MARK;
5255     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5256     SP = MARK;
5257     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5258             ? newRV_noinc(av) : av);
5259     RETURN;
5260 }
5261
5262 PP(pp_anonhash)
5263 {
5264     dSP; dMARK; dORIGMARK;
5265     HV* const hv = newHV();
5266     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5267                                     ? newRV_noinc(MUTABLE_SV(hv))
5268                                     : MUTABLE_SV(hv) );
5269
5270     while (MARK < SP) {
5271         SV * const key =
5272             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5273         SV *val;
5274         if (MARK < SP)
5275         {
5276             MARK++;
5277             SvGETMAGIC(*MARK);
5278             val = newSV(0);
5279             sv_setsv_nomg(val, *MARK);
5280         }
5281         else
5282         {
5283             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5284             val = newSV(0);
5285         }
5286         (void)hv_store_ent(hv,key,val,0);
5287     }
5288     SP = ORIGMARK;
5289     XPUSHs(retval);
5290     RETURN;
5291 }
5292
5293 PP(pp_splice)
5294 {
5295     dSP; dMARK; dORIGMARK;
5296     int num_args = (SP - MARK);
5297     AV *ary = MUTABLE_AV(*++MARK);
5298     SV **src;
5299     SV **dst;
5300     SSize_t i;
5301     SSize_t offset;
5302     SSize_t length;
5303     SSize_t newlen;
5304     SSize_t after;
5305     SSize_t diff;
5306     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5307
5308     if (mg) {
5309         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5310                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5311                                     sp - mark);
5312     }
5313
5314     SP++;
5315
5316     if (++MARK < SP) {
5317         offset = i = SvIV(*MARK);
5318         if (offset < 0)
5319             offset += AvFILLp(ary) + 1;
5320         if (offset < 0)
5321             DIE(aTHX_ PL_no_aelem, i);
5322         if (++MARK < SP) {
5323             length = SvIVx(*MARK++);
5324             if (length < 0) {
5325                 length += AvFILLp(ary) - offset + 1;
5326                 if (length < 0)
5327                     length = 0;
5328             }
5329         }
5330         else
5331             length = AvMAX(ary) + 1;            /* close enough to infinity */
5332     }
5333     else {
5334         offset = 0;
5335         length = AvMAX(ary) + 1;
5336     }
5337     if (offset > AvFILLp(ary) + 1) {
5338         if (num_args > 2)
5339             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5340         offset = AvFILLp(ary) + 1;
5341     }
5342     after = AvFILLp(ary) + 1 - (offset + length);
5343     if (after < 0) {                            /* not that much array */
5344         length += after;                        /* offset+length now in array */
5345         after = 0;
5346         if (!AvALLOC(ary))
5347             av_extend(ary, 0);
5348     }
5349
5350     /* At this point, MARK .. SP-1 is our new LIST */
5351
5352     newlen = SP - MARK;
5353     diff = newlen - length;
5354     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5355         av_reify(ary);
5356
5357     /* make new elements SVs now: avoid problems if they're from the array */
5358     for (dst = MARK, i = newlen; i; i--) {
5359         SV * const h = *dst;
5360         *dst++ = newSVsv(h);
5361     }
5362
5363     if (diff < 0) {                             /* shrinking the area */
5364         SV **tmparyval = NULL;
5365         if (newlen) {
5366             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5367             Copy(MARK, tmparyval, newlen, SV*);
5368         }
5369
5370         MARK = ORIGMARK + 1;
5371         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5372             const bool real = cBOOL(AvREAL(ary));
5373             MEXTEND(MARK, length);
5374             if (real)
5375                 EXTEND_MORTAL(length);
5376             for (i = 0, dst = MARK; i < length; i++) {
5377                 if ((*dst = AvARRAY(ary)[i+offset])) {
5378                   if (real)
5379                     sv_2mortal(*dst);   /* free them eventually */
5380                 }
5381                 else
5382                     *dst = &PL_sv_undef;
5383                 dst++;
5384             }
5385             MARK += length - 1;
5386         }
5387         else {
5388             *MARK = AvARRAY(ary)[offset+length-1];
5389             if (AvREAL(ary)) {
5390                 sv_2mortal(*MARK);
5391                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5392                     SvREFCNT_dec(*dst++);       /* free them now */
5393             }
5394             if (!*MARK)
5395                 *MARK = &PL_sv_undef;
5396         }
5397         AvFILLp(ary) += diff;
5398
5399         /* pull up or down? */
5400
5401         if (offset < after) {                   /* easier to pull up */
5402             if (offset) {                       /* esp. if nothing to pull */
5403                 src = &AvARRAY(ary)[offset-1];
5404                 dst = src - diff;               /* diff is negative */
5405                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5406                     *dst-- = *src--;
5407             }
5408             dst = AvARRAY(ary);
5409             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5410             AvMAX(ary) += diff;
5411         }
5412         else {
5413             if (after) {                        /* anything to pull down? */
5414                 src = AvARRAY(ary) + offset + length;
5415                 dst = src + diff;               /* diff is negative */
5416                 Move(src, dst, after, SV*);
5417             }
5418             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5419                                                 /* avoid later double free */
5420         }
5421         i = -diff;
5422         while (i)
5423             dst[--i] = NULL;
5424
5425         if (newlen) {
5426             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5427             Safefree(tmparyval);
5428         }
5429     }
5430     else {                                      /* no, expanding (or same) */
5431         SV** tmparyval = NULL;
5432         if (length) {
5433             Newx(tmparyval, length, SV*);       /* so remember deletion */
5434             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5435         }
5436
5437         if (diff > 0) {                         /* expanding */
5438             /* push up or down? */
5439             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5440                 if (offset) {
5441                     src = AvARRAY(ary);
5442                     dst = src - diff;
5443                     Move(src, dst, offset, SV*);
5444                 }
5445                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5446                 AvMAX(ary) += diff;
5447                 AvFILLp(ary) += diff;
5448             }
5449             else {
5450                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5451                     av_extend(ary, AvFILLp(ary) + diff);
5452                 AvFILLp(ary) += diff;
5453
5454                 if (after) {
5455                     dst = AvARRAY(ary) + AvFILLp(ary);
5456                     src = dst - diff;
5457                     for (i = after; i; i--) {
5458                         *dst-- = *src--;
5459                     }
5460                 }
5461             }
5462         }
5463
5464         if (newlen) {
5465             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5466         }
5467
5468         MARK = ORIGMARK + 1;
5469         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5470             if (length) {
5471                 const bool real = cBOOL(AvREAL(ary));
5472                 if (real)
5473                     EXTEND_MORTAL(length);
5474                 for (i = 0, dst = MARK; i < length; i++) {
5475                     if ((*dst = tmparyval[i])) {
5476                       if (real)
5477                         sv_2mortal(*dst);       /* free them eventually */
5478                     }
5479                     else *dst = &PL_sv_undef;
5480                     dst++;
5481                 }
5482             }
5483             MARK += length - 1;
5484         }
5485         else if (length--) {
5486             *MARK = tmparyval[length];
5487             if (AvREAL(ary)) {
5488                 sv_2mortal(*MARK);
5489                 while (length-- > 0)
5490                     SvREFCNT_dec(tmparyval[length]);
5491             }
5492             if (!*MARK)
5493                 *MARK = &PL_sv_undef;
5494         }
5495         else
5496             *MARK = &PL_sv_undef;
5497         Safefree(tmparyval);
5498     }
5499
5500     if (SvMAGICAL(ary))
5501         mg_set(MUTABLE_SV(ary));
5502
5503     SP = MARK;
5504     RETURN;
5505 }
5506
5507 PP(pp_push)
5508 {
5509     dSP; dMARK; dORIGMARK; dTARGET;
5510     AV * const ary = MUTABLE_AV(*++MARK);
5511     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5512
5513     if (mg) {
5514         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5515         PUSHMARK(MARK);
5516         PUTBACK;
5517         ENTER_with_name("call_PUSH");
5518         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5519         LEAVE_with_name("call_PUSH");
5520         /* SPAGAIN; not needed: SP is assigned to immediately below */
5521     }
5522     else {
5523         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5524          * only need to save locally, not on the save stack */
5525         U16 old_delaymagic = PL_delaymagic;
5526
5527         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5528         PL_delaymagic = DM_DELAY;
5529         for (++MARK; MARK <= SP; MARK++) {
5530             SV *sv;
5531             if (*MARK) SvGETMAGIC(*MARK);
5532             sv = newSV(0);
5533             if (*MARK)
5534                 sv_setsv_nomg(sv, *MARK);
5535             av_store(ary, AvFILLp(ary)+1, sv);
5536         }
5537         if (PL_delaymagic & DM_ARRAY_ISA)
5538             mg_set(MUTABLE_SV(ary));
5539         PL_delaymagic = old_delaymagic;
5540     }
5541     SP = ORIGMARK;
5542     if (OP_GIMME(PL_op, 0) != G_VOID) {
5543         PUSHi( AvFILL(ary) + 1 );
5544     }
5545     RETURN;
5546 }
5547
5548 /* also used for: pp_pop()*/
5549 PP(pp_shift)
5550 {
5551     dSP;
5552     AV * const av = PL_op->op_flags & OPf_SPECIAL
5553         ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5554     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5555     EXTEND(SP, 1);
5556     assert (sv);
5557     if (AvREAL(av))
5558         (void)sv_2mortal(sv);
5559     PUSHs(sv);
5560     RETURN;
5561 }
5562
5563 PP(pp_unshift)
5564 {
5565     dSP; dMARK; dORIGMARK; dTARGET;
5566     AV *ary = MUTABLE_AV(*++MARK);
5567     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5568
5569     if (mg) {
5570         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5571         PUSHMARK(MARK);
5572         PUTBACK;
5573         ENTER_with_name("call_UNSHIFT");
5574         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5575         LEAVE_with_name("call_UNSHIFT");
5576         /* SPAGAIN; not needed: SP is assigned to immediately below */
5577     }
5578     else {
5579         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5580          * only need to save locally, not on the save stack */
5581         U16 old_delaymagic = PL_delaymagic;
5582         SSize_t i = 0;
5583
5584         av_unshift(ary, SP - MARK);
5585         PL_delaymagic = DM_DELAY;
5586         while (MARK < SP) {
5587             SV * const sv = newSVsv(*++MARK);
5588             (void)av_store(ary, i++, sv);
5589         }
5590         if (PL_delaymagic & DM_ARRAY_ISA)
5591             mg_set(MUTABLE_SV(ary));
5592         PL_delaymagic = old_delaymagic;
5593     }
5594     SP = ORIGMARK;
5595     if (OP_GIMME(PL_op, 0) != G_VOID) {
5596         PUSHi( AvFILL(ary) + 1 );
5597     }
5598     RETURN;
5599 }
5600
5601 PP(pp_reverse)
5602 {
5603     dSP; dMARK;
5604
5605     if (GIMME_V == G_ARRAY) {
5606         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5607             AV *av;
5608
5609             /* See pp_sort() */
5610             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5611             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5612             av = MUTABLE_AV((*SP));
5613             /* In-place reversing only happens in void context for the array
5614              * assignment. We don't need to push anything on the stack. */
5615             SP = MARK;
5616
5617             if (SvMAGICAL(av)) {
5618                 SSize_t i, j;
5619                 SV *tmp = sv_newmortal();
5620                 /* For SvCANEXISTDELETE */
5621                 HV *stash;
5622                 const MAGIC *mg;
5623                 bool can_preserve = SvCANEXISTDELETE(av);
5624
5625                 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5626                     SV *begin, *end;
5627
5628                     if (can_preserve) {
5629                         if (!av_exists(av, i)) {
5630                             if (av_exists(av, j)) {
5631                                 SV *sv = av_delete(av, j, 0);
5632                                 begin = *av_fetch(av, i, TRUE);
5633                                 sv_setsv_mg(begin, sv);
5634                             }
5635                             continue;
5636                         }
5637                         else if (!av_exists(av, j)) {
5638                             SV *sv = av_delete(av, i, 0);
5639                             end = *av_fetch(av, j, TRUE);
5640                             sv_setsv_mg(end, sv);
5641                             continue;
5642                         }
5643                     }
5644
5645                     begin = *av_fetch(av, i, TRUE);
5646                     end   = *av_fetch(av, j, TRUE);
5647                     sv_setsv(tmp,      begin);
5648                     sv_setsv_mg(begin, end);
5649                     sv_setsv_mg(end,   tmp);
5650                 }
5651             }
5652             else {
5653                 SV **begin = AvARRAY(av);
5654
5655                 if (begin) {
5656                     SV **end   = begin + AvFILLp(av);
5657
5658                     while (begin < end) {
5659                         SV * const tmp = *begin;
5660                         *begin++ = *end;
5661                         *end--   = tmp;
5662                     }
5663                 }
5664             }
5665         }
5666         else {
5667             SV **oldsp = SP;
5668             MARK++;
5669             while (MARK < SP) {
5670                 SV * const tmp = *MARK;
5671                 *MARK++ = *SP;
5672                 *SP--   = tmp;
5673             }
5674             /* safe as long as stack cannot get extended in the above */
5675             SP = oldsp;
5676         }
5677     }
5678     else {
5679         char *up;
5680         dTARGET;
5681         STRLEN len;
5682
5683         SvUTF8_off(TARG);                               /* decontaminate */
5684         if (SP - MARK > 1)
5685             do_join(TARG, &PL_sv_no, MARK, SP);
5686         else if (SP > MARK)
5687             sv_setsv(TARG, *SP);
5688         else {
5689             sv_setsv(TARG, DEFSV);
5690             EXTEND(SP, 1);
5691         }
5692
5693         up = SvPV_force(TARG, len);
5694         if (len > 1) {
5695             char *down;
5696             if (DO_UTF8(TARG)) {        /* first reverse each character */
5697                 U8* s = (U8*)SvPVX(TARG);
5698                 const U8* send = (U8*)(s + len);
5699                 while (s < send) {
5700                     if (UTF8_IS_INVARIANT(*s)) {
5701                         s++;
5702                         continue;
5703                     }
5704                     else {
5705                         if (!utf8_to_uvchr_buf(s, send, 0))
5706                             break;
5707                         up = (char*)s;
5708                         s += UTF8SKIP(s);
5709                         down = (char*)(s - 1);
5710                         /* reverse this character */
5711                         while (down > up) {
5712                             const char tmp = *up;
5713                             *up++ = *down;
5714                             *down-- = tmp;
5715                         }
5716                     }
5717                 }
5718                 up = SvPVX(TARG);
5719             }
5720             down = SvPVX(TARG) + len - 1;
5721             while (down > up) {
5722                 const char tmp = *up;
5723                 *up++ = *down;
5724                 *down-- = tmp;
5725             }
5726             (void)SvPOK_only_UTF8(TARG);
5727         }
5728         SP = MARK + 1;
5729         SETTARG;
5730     }
5731     RETURN;
5732 }
5733
5734 PP(pp_split)
5735 {
5736     dSP; dTARG;
5737     AV *ary = (   (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5738                && (PL_op->op_flags & OPf_STACKED))      /* @{expr} = split */
5739                ? (AV *)POPs : NULL;
5740     IV limit = POPi;                    /* note, negative is forever */
5741     SV * const sv = POPs;
5742     STRLEN len;
5743     const char *s = SvPV_const(sv, len);
5744     const bool do_utf8 = DO_UTF8(sv);
5745     const char *strend = s + len;
5746     PMOP *pm = cPMOPx(PL_op);
5747     REGEXP *rx;
5748     SV *dstr;
5749     const char *m;
5750     SSize_t iters = 0;
5751     const STRLEN slen = do_utf8
5752                         ? utf8_length((U8*)s, (U8*)strend)
5753                         : (STRLEN)(strend - s);
5754     SSize_t maxiters = slen + 10;
5755     I32 trailing_empty = 0;
5756     const char *orig;
5757     const IV origlimit = limit;
5758     I32 realarray = 0;
5759     I32 base;
5760     const U8 gimme = GIMME_V;
5761     bool gimme_scalar;
5762     I32 oldsave = PL_savestack_ix;
5763     U32 make_mortal = SVs_TEMP;
5764     bool multiline = 0;
5765     MAGIC *mg = NULL;
5766
5767     rx = PM_GETRE(pm);
5768
5769     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5770              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5771
5772     /* handle @ary = split(...) optimisation */
5773     if (PL_op->op_private & OPpSPLIT_ASSIGN) {
5774         if (!(PL_op->op_flags & OPf_STACKED)) {
5775             if (PL_op->op_private & OPpSPLIT_LEX) {
5776                 if (PL_op->op_private & OPpLVAL_INTRO)
5777                     SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5778                 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
5779             }
5780             else {
5781                 GV *gv =
5782 #ifdef USE_ITHREADS
5783                         MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5784 #else
5785                         pm->op_pmreplrootu.op_pmtargetgv;
5786 #endif
5787                 if (PL_op->op_private & OPpLVAL_INTRO)
5788                     ary = save_ary(gv);
5789                 else
5790                     ary = GvAVn(gv);
5791             }
5792             /* skip anything pushed by OPpLVAL_INTRO above */
5793             oldsave = PL_savestack_ix;
5794         }
5795
5796         realarray = 1;
5797         PUTBACK;
5798         av_extend(ary,0);
5799         (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
5800         av_clear(ary);
5801         SPAGAIN;
5802         if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5803             PUSHMARK(SP);
5804             XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5805         }
5806         else {
5807             if (!AvREAL(ary)) {
5808                 I32 i;
5809                 AvREAL_on(ary);
5810                 AvREIFY_off(ary);
5811                 for (i = AvFILLp(ary); i >= 0; i--)
5812                     AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5813             }
5814             /* temporarily switch stacks */
5815             SAVESWITCHSTACK(PL_curstack, ary);
5816             make_mortal = 0;
5817         }
5818     }
5819
5820     base = SP - PL_stack_base;
5821     orig = s;
5822     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5823         if (do_utf8) {
5824             while (s < strend && isSPACE_utf8_safe(s, strend))
5825                 s += UTF8SKIP(s);
5826         }
5827         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5828             while (s < strend && isSPACE_LC(*s))
5829                 s++;
5830         }
5831         else {
5832             while (s < strend && isSPACE(*s))
5833                 s++;
5834         }
5835     }
5836     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5837         multiline = 1;
5838     }
5839
5840     gimme_scalar = gimme == G_SCALAR && !ary;
5841
5842     if (!limit)
5843         limit = maxiters + 2;
5844     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5845         while (--limit) {
5846             m = s;
5847             /* this one uses 'm' and is a negative test */
5848             if (do_utf8) {
5849                 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
5850                     const int t = UTF8SKIP(m);
5851                     /* isSPACE_utf8_safe returns FALSE for malform utf8 */
5852                     if (strend - m < t)
5853                         m = strend;
5854                     else
5855                         m += t;
5856                 }
5857             }
5858             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5859             {
5860                 while (m < strend && !isSPACE_LC(*m))
5861                     ++m;
5862             } else {
5863                 while (m < strend && !isSPACE(*m))
5864                     ++m;
5865             }
5866             if (m >= strend)
5867                 break;
5868
5869             if (gimme_scalar) {
5870                 iters++;
5871                 if (m-s == 0)
5872                     trailing_empty++;
5873                 else
5874                     trailing_empty = 0;
5875             } else {
5876                 dstr = newSVpvn_flags(s, m-s,
5877                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5878                 XPUSHs(dstr);
5879             }
5880
5881             /* skip the whitespace found last */
5882             if (do_utf8)
5883                 s = m + UTF8SKIP(m);
5884             else
5885                 s = m + 1;
5886
5887             /* this one uses 's' and is a positive test */
5888             if (do_utf8) {
5889                 while (s < strend && isSPACE_utf8_safe(s, strend) )
5890                     s +=  UTF8SKIP(s);
5891             }
5892             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5893             {
5894                 while (s < strend && isSPACE_LC(*s))
5895                     ++s;
5896             } else {
5897                 while (s < strend && isSPACE(*s))
5898                     ++s;
5899             }
5900         }
5901     }
5902     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5903         while (--limit) {
5904             for (m = s; m < strend && *m != '\n'; m++)
5905                 ;
5906             m++;
5907             if (m >= strend)
5908                 break;
5909
5910             if (gimme_scalar) {
5911                 iters++;
5912                 if (m-s == 0)
5913                     trailing_empty++;
5914                 else
5915                     trailing_empty = 0;
5916             } else {
5917                 dstr = newSVpvn_flags(s, m-s,
5918                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5919                 XPUSHs(dstr);
5920             }
5921             s = m;
5922         }
5923     }
5924     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5925         /*
5926           Pre-extend the stack, either the number of bytes or
5927           characters in the string or a limited amount, triggered by:
5928
5929           my ($x, $y) = split //, $str;
5930             or
5931           split //, $str, $i;
5932         */
5933         if (!gimme_scalar) {
5934             const IV items = limit - 1;
5935             /* setting it to -1 will trigger a panic in EXTEND() */
5936             const SSize_t sslen = slen > SSize_t_MAX ?  -1 : (SSize_t)slen;
5937             if (items >=0 && items < sslen)
5938                 EXTEND(SP, items);
5939             else
5940                 EXTEND(SP, sslen);
5941         }
5942
5943         if (do_utf8) {
5944             while (--limit) {
5945                 /* keep track of how many bytes we skip over */
5946                 m = s;
5947                 s += UTF8SKIP(s);
5948                 if (gimme_scalar) {
5949                     iters++;
5950                     if (s-m == 0)
5951                         trailing_empty++;
5952                     else
5953                         trailing_empty = 0;
5954                 } else {
5955                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5956
5957                     PUSHs(dstr);
5958                 }
5959
5960                 if (s >= strend)
5961                     break;
5962             }
5963         } else {
5964             while (--limit) {
5965                 if (gimme_scalar) {
5966                     iters++;
5967                 } else {
5968                     dstr = newSVpvn(s, 1);
5969
5970
5971                     if (make_mortal)
5972                         sv_2mortal(dstr);
5973
5974                     PUSHs(dstr);
5975                 }
5976
5977                 s++;
5978
5979                 if (s >= strend)
5980                     break;
5981             }
5982         }
5983     }
5984     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5985              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5986              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5987              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5988         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5989         SV * const csv = CALLREG_INTUIT_STRING(rx);
5990
5991         len = RX_MINLENRET(rx);
5992         if (len == 1 && !RX_UTF8(rx) && !tail) {
5993             const char c = *SvPV_nolen_const(csv);
5994             while (--limit) {
5995                 for (m = s; m < strend && *m != c; m++)
5996                     ;
5997                 if (m >= strend)
5998                     break;
5999                 if (gimme_scalar) {
6000                     iters++;
6001                     if (m-s == 0)
6002                         trailing_empty++;
6003                     else
6004                         trailing_empty = 0;
6005                 } else {
6006                     dstr = newSVpvn_flags(s, m-s,
6007                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6008                     XPUSHs(dstr);
6009                 }
6010                 /* The rx->minlen is in characters but we want to step
6011                  * s ahead by bytes. */
6012                 if (do_utf8)
6013                     s = (char*)utf8_hop((U8*)m, len);
6014                 else
6015                     s = m + len; /* Fake \n at the end */
6016             }
6017         }
6018         else {
6019             while (s < strend && --limit &&
6020               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6021                              csv, multiline ? FBMrf_MULTILINE : 0)) )
6022             {
6023                 if (gimme_scalar) {
6024                     iters++;
6025                     if (m-s == 0)
6026                         trailing_empty++;
6027                     else
6028                         trailing_empty = 0;
6029                 } else {
6030                     dstr = newSVpvn_flags(s, m-s,
6031                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6032                     XPUSHs(dstr);
6033                 }
6034                 /* The rx->minlen is in characters but we want to step
6035                  * s ahead by bytes. */
6036                 if (do_utf8)
6037                     s = (char*)utf8_hop((U8*)m, len);
6038                 else
6039                     s = m + len; /* Fake \n at the end */
6040             }
6041         }
6042     }
6043     else {
6044         maxiters += slen * RX_NPARENS(rx);
6045         while (s < strend && --limit)
6046         {
6047             I32 rex_return;
6048             PUTBACK;
6049             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6050                                      sv, NULL, 0);
6051             SPAGAIN;
6052             if (rex_return == 0)
6053                 break;
6054             TAINT_IF(RX_MATCH_TAINTED(rx));
6055             /* we never pass the REXEC_COPY_STR flag, so it should
6056              * never get copied */
6057             assert(!RX_MATCH_COPIED(rx));
6058             m = RX_OFFS(rx)[0].start + orig;
6059
6060             if (gimme_scalar) {
6061                 iters++;
6062                 if (m-s == 0)
6063                     trailing_empty++;
6064                 else
6065                     trailing_empty = 0;
6066             } else {
6067                 dstr = newSVpvn_flags(s, m-s,
6068                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6069                 XPUSHs(dstr);
6070             }
6071             if (RX_NPARENS(rx)) {
6072                 I32 i;
6073                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6074                     s = RX_OFFS(rx)[i].start + orig;
6075                     m = RX_OFFS(rx)[i].end + orig;
6076
6077                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
6078                        parens that didn't match -- they should be set to
6079                        undef, not the empty string */
6080                     if (gimme_scalar) {
6081                         iters++;
6082                         if (m-s == 0)
6083                             trailing_empty++;
6084                         else
6085                             trailing_empty = 0;
6086                     } else {
6087                         if (m >= orig && s >= orig) {
6088                             dstr = newSVpvn_flags(s, m-s,
6089                                                  (do_utf8 ? SVf_UTF8 : 0)
6090                                                   | make_mortal);
6091                         }
6092                         else
6093                             dstr = &PL_sv_undef;  /* undef, not "" */
6094                         XPUSHs(dstr);
6095                     }
6096
6097                 }
6098             }
6099             s = RX_OFFS(rx)[0].end + orig;
6100         }
6101     }
6102
6103     if (!gimme_scalar) {
6104         iters = (SP - PL_stack_base) - base;
6105     }
6106     if (iters > maxiters)
6107         DIE(aTHX_ "Split loop");
6108
6109     /* keep field after final delim? */
6110     if (s < strend || (iters && origlimit)) {
6111         if (!gimme_scalar) {
6112             const STRLEN l = strend - s;
6113             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6114             XPUSHs(dstr);
6115         }
6116         iters++;
6117     }
6118     else if (!origlimit) {
6119         if (gimme_scalar) {
6120             iters -= trailing_empty;
6121         } else {
6122             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6123                 if (TOPs && !make_mortal)
6124                     sv_2mortal(TOPs);
6125                 *SP-- = NULL;
6126                 iters--;
6127             }
6128         }
6129     }
6130
6131     PUTBACK;
6132     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6133     SPAGAIN;
6134     if (realarray) {
6135         if (!mg) {
6136             if (SvSMAGICAL(ary)) {
6137                 PUTBACK;
6138                 mg_set(MUTABLE_SV(ary));
6139                 SPAGAIN;
6140             }
6141             if (gimme == G_ARRAY) {
6142                 EXTEND(SP, iters);
6143                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6144                 SP += iters;
6145                 RETURN;
6146             }
6147         }
6148         else {
6149             PUTBACK;
6150             ENTER_with_name("call_PUSH");
6151             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6152             LEAVE_with_name("call_PUSH");
6153             SPAGAIN;
6154             if (gimme == G_ARRAY) {
6155                 SSize_t i;
6156                 /* EXTEND should not be needed - we just popped them */
6157                 EXTEND(SP, iters);
6158                 for (i=0; i < iters; i++) {
6159                     SV **svp = av_fetch(ary, i, FALSE);
6160                     PUSHs((svp) ? *svp : &PL_sv_undef);
6161                 }
6162                 RETURN;
6163             }
6164         }
6165     }
6166     else {
6167         if (gimme == G_ARRAY)
6168             RETURN;
6169     }
6170
6171     GETTARGET;
6172     XPUSHi(iters);
6173     RETURN;
6174 }
6175
6176 PP(pp_once)
6177 {
6178     dSP;
6179     SV *const sv = PAD_SVl(PL_op->op_targ);
6180
6181     if (SvPADSTALE(sv)) {
6182         /* First time. */
6183         SvPADSTALE_off(sv);
6184         RETURNOP(cLOGOP->op_other);
6185     }
6186     RETURNOP(cLOGOP->op_next);
6187 }
6188
6189 PP(pp_lock)
6190 {
6191     dSP;
6192     dTOPss;
6193     SV *retsv = sv;
6194     SvLOCK(sv);
6195     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6196      || SvTYPE(retsv) == SVt_PVCV) {
6197         retsv = refto(retsv);
6198     }
6199     SETs(retsv);
6200     RETURN;
6201 }
6202
6203
6204 /* used for: pp_padany(), pp_custom(); plus any system ops
6205  * that aren't implemented on a particular platform */
6206
6207 PP(unimplemented_op)
6208 {
6209     const Optype op_type = PL_op->op_type;
6210     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6211        with out of range op numbers - it only "special" cases op_custom.
6212        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6213        if we get here for a custom op then that means that the custom op didn't
6214        have an implementation. Given that OP_NAME() looks up the custom op
6215        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6216        registers &PL_unimplemented_op as the address of their custom op.
6217        NULL doesn't generate a useful error message. "custom" does. */
6218     const char *const name = op_type >= OP_max
6219         ? "[out of range]" : PL_op_name[PL_op->op_type];
6220     if(OP_IS_SOCKET(op_type))
6221         DIE(aTHX_ PL_no_sock_func, name);
6222     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
6223 }
6224
6225 static void
6226 S_maybe_unwind_defav(pTHX)
6227 {
6228     if (CX_CUR()->cx_type & CXp_HASARGS) {
6229         PERL_CONTEXT *cx = CX_CUR();
6230
6231         assert(CxHASARGS(cx));
6232         cx_popsub_args(cx);
6233         cx->cx_type &= ~CXp_HASARGS;
6234     }
6235 }
6236
6237 /* For sorting out arguments passed to a &CORE:: subroutine */
6238 PP(pp_coreargs)
6239 {
6240     dSP;
6241     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6242     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6243     AV * const at_ = GvAV(PL_defgv);
6244     SV **svp = at_ ? AvARRAY(at_) : NULL;
6245     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6246     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6247     bool seen_question = 0;
6248     const char *err = NULL;
6249     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6250
6251     /* Count how many args there are first, to get some idea how far to
6252        extend the stack. */
6253     while (oa) {
6254         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6255         maxargs++;
6256         if (oa & OA_OPTIONAL) seen_question = 1;
6257         if (!seen_question) minargs++;
6258         oa >>= 4;
6259     }
6260
6261     if(numargs < minargs) err = "Not enough";
6262     else if(numargs > maxargs) err = "Too many";
6263     if (err)
6264         /* diag_listed_as: Too many arguments for %s */
6265         Perl_croak(aTHX_
6266           "%s arguments for %s", err,
6267            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6268         );
6269
6270     /* Reset the stack pointer.  Without this, we end up returning our own
6271        arguments in list context, in addition to the values we are supposed
6272        to return.  nextstate usually does this on sub entry, but we need
6273        to run the next op with the caller's hints, so we cannot have a
6274        nextstate. */
6275     SP = PL_stack_base + CX_CUR()->blk_oldsp;
6276
6277     if(!maxargs) RETURN;
6278
6279     /* We do this here, rather than with a separate pushmark op, as it has
6280        to come in between two things this function does (stack reset and
6281        arg pushing).  This seems the easiest way to do it. */
6282     if (pushmark) {
6283         PUTBACK;
6284         (void)Perl_pp_pushmark(aTHX);
6285     }
6286
6287     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6288     PUTBACK; /* The code below can die in various places. */
6289
6290     oa = PL_opargs[opnum] >> OASHIFT;
6291     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6292         whicharg++;
6293         switch (oa & 7) {
6294         case OA_SCALAR:
6295           try_defsv:
6296             if (!numargs && defgv && whicharg == minargs + 1) {
6297                 PUSHs(DEFSV);
6298             }
6299             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6300             break;
6301         case OA_LIST:
6302             while (numargs--) {
6303                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6304                 svp++;
6305             }
6306             RETURN;
6307         case OA_AVREF:
6308             if (!numargs) {
6309                 GV *gv;
6310                 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6311                     gv = PL_argvgv;
6312                 else {
6313                     S_maybe_unwind_defav(aTHX);
6314                     gv = PL_defgv;
6315                 }
6316                 PUSHs((SV *)GvAVn(gv));
6317                 break;
6318             }
6319             if (!svp || !*svp || !SvROK(*svp)
6320              || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6321                 DIE(aTHX_
6322                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6323                  "Type of arg %d to &CORE::%s must be array reference",
6324                   whicharg, PL_op_desc[opnum]
6325                 );
6326             PUSHs(SvRV(*svp));
6327             break;
6328         case OA_HVREF:
6329             if (!svp || !*svp || !SvROK(*svp)
6330              || (  SvTYPE(SvRV(*svp)) != SVt_PVHV
6331                 && (  opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6332                    || SvTYPE(SvRV(*svp)) != SVt_PVAV  )))
6333                 DIE(aTHX_
6334                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6335                  "Type of arg %d to &CORE::%s must be hash%s reference",
6336                   whicharg, PL_op_desc[opnum],
6337                   opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6338                      ? ""
6339                      : " or array"
6340                 );
6341             PUSHs(SvRV(*svp));
6342             break;
6343         case OA_FILEREF:
6344             if (!numargs) PUSHs(NULL);
6345             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6346                 /* no magic here, as the prototype will have added an extra
6347                    refgen and we just want what was there before that */
6348                 PUSHs(SvRV(*svp));
6349             else {
6350                 const bool constr = PL_op->op_private & whicharg;
6351                 PUSHs(S_rv2gv(aTHX_
6352                     svp && *svp ? *svp : &PL_sv_undef,
6353                     constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6354                     !constr
6355                 ));
6356             }
6357             break;
6358         case OA_SCALARREF:
6359           if (!numargs) goto try_defsv;
6360           else {
6361             const bool wantscalar =
6362                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6363             if (!svp || !*svp || !SvROK(*svp)
6364                 /* We have to permit globrefs even for the \$ proto, as
6365                    *foo is indistinguishable from ${\*foo}, and the proto-
6366                    type permits the latter. */
6367              || SvTYPE(SvRV(*svp)) > (
6368                      wantscalar       ? SVt_PVLV
6369                    : opnum == OP_LOCK || opnum == OP_UNDEF
6370                                       ? SVt_PVCV
6371                    :                    SVt_PVHV
6372                 )
6373                )
6374                 DIE(aTHX_
6375                  "Type of arg %d to &CORE::%s must be %s",
6376                   whicharg, PL_op_name[opnum],
6377                   wantscalar
6378                     ? "scalar reference"
6379                     : opnum == OP_LOCK || opnum == OP_UNDEF
6380                        ? "reference to one of [$@%&*]"
6381                        : "reference to one of [$@%*]"
6382                 );
6383             PUSHs(SvRV(*svp));
6384             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6385                 /* Undo @_ localisation, so that sub exit does not undo
6386                    part of our undeffing. */
6387                 S_maybe_unwind_defav(aTHX);
6388             }
6389           }
6390           break;
6391         default:
6392             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6393         }
6394         oa = oa >> 4;
6395     }
6396
6397     RETURN;
6398 }
6399
6400 PP(pp_avhvswitch)
6401 {
6402     dVAR; dSP;
6403     return PL_ppaddr[
6404                 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6405                     + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6406            ](aTHX);
6407 }
6408
6409 PP(pp_runcv)
6410 {
6411     dSP;
6412     CV *cv;
6413     if (PL_op->op_private & OPpOFFBYONE) {
6414         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6415     }
6416     else cv = find_runcv(NULL);
6417     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6418     RETURN;
6419 }
6420
6421 static void
6422 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6423                             const bool can_preserve)
6424 {
6425     const SSize_t ix = SvIV(keysv);
6426     if (can_preserve ? av_exists(av, ix) : TRUE) {
6427         SV ** const svp = av_fetch(av, ix, 1);
6428         if (!svp || !*svp)
6429             Perl_croak(aTHX_ PL_no_aelem, ix);
6430         save_aelem(av, ix, svp);
6431     }
6432     else
6433         SAVEADELETE(av, ix);
6434 }
6435
6436 static void
6437 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6438                             const bool can_preserve)
6439 {
6440     if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6441         HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6442         SV ** const svp = he ? &HeVAL(he) : NULL;
6443         if (!svp || !*svp)
6444             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6445         save_helem_flags(hv, keysv, svp, 0);
6446     }
6447     else
6448         SAVEHDELETE(hv, keysv);
6449 }
6450
6451 static void
6452 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6453 {
6454     if (type == OPpLVREF_SV) {
6455         save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6456         GvSV(gv) = 0;
6457     }
6458     else if (type == OPpLVREF_AV)
6459         /* XXX Inefficient, as it creates a new AV, which we are
6460                about to clobber.  */
6461         save_ary(gv);
6462     else {
6463         assert(type == OPpLVREF_HV);
6464         /* XXX Likewise inefficient.  */
6465         save_hash(gv);
6466     }
6467 }
6468
6469
6470 PP(pp_refassign)
6471 {
6472     dSP;
6473     SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6474     SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6475     dTOPss;
6476     const char *bad = NULL;
6477     const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6478     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6479     switch (type) {
6480     case OPpLVREF_SV:
6481         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6482             bad = " SCALAR";
6483         break;
6484     case OPpLVREF_AV:
6485         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6486             bad = "n ARRAY";
6487         break;
6488     case OPpLVREF_HV:
6489         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6490             bad = " HASH";
6491         break;
6492     case OPpLVREF_CV:
6493         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6494             bad = " CODE";
6495     }
6496     if (bad)
6497         /* diag_listed_as: Assigned value is not %s reference */
6498         DIE(aTHX_ "Assigned value is not a%s reference", bad);
6499     {
6500     MAGIC *mg;
6501     HV *stash;
6502     switch (left ? SvTYPE(left) : 0) {
6503     case 0:
6504     {
6505         SV * const old = PAD_SV(ARGTARG);
6506         PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6507         SvREFCNT_dec(old);
6508         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6509                 == OPpLVAL_INTRO)
6510             SAVECLEARSV(PAD_SVl(ARGTARG));
6511         break;
6512     }
6513     case SVt_PVGV:
6514         if (PL_op->op_private & OPpLVAL_INTRO) {
6515             S_localise_gv_slot(aTHX_ (GV *)left, type);
6516         }
6517         gv_setref(left, sv);
6518         SvSETMAGIC(left);
6519         break;
6520     case SVt_PVAV:
6521         assert(key);
6522         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6523             S_localise_aelem_lval(aTHX_ (AV *)left, key,
6524                                         SvCANEXISTDELETE(left));
6525         }
6526         av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6527         break;
6528     case SVt_PVHV:
6529         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6530             assert(key);
6531             S_localise_helem_lval(aTHX_ (HV *)left, key,
6532                                         SvCANEXISTDELETE(left));
6533         }
6534         (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6535     }
6536     if (PL_op->op_flags & OPf_MOD)
6537         SETs(sv_2mortal(newSVsv(sv)));
6538     /* XXX else can weak references go stale before they are read, e.g.,
6539        in leavesub?  */
6540     RETURN;
6541     }
6542 }
6543
6544 PP(pp_lvref)
6545 {
6546     dSP;
6547     SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6548     SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6549     SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6550     MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6551                                    &PL_vtbl_lvref, (char *)elem,
6552                                    elem ? HEf_SVKEY : (I32)ARGTARG);
6553     mg->mg_private = PL_op->op_private;
6554     if (PL_op->op_private & OPpLVREF_ITER)
6555         mg->mg_flags |= MGf_PERSIST;
6556     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6557       if (elem) {
6558         MAGIC *mg;
6559         HV *stash;
6560         assert(arg);
6561         {
6562             const bool can_preserve = SvCANEXISTDELETE(arg);
6563             if (SvTYPE(arg) == SVt_PVAV)
6564               S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6565             else
6566               S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6567         }
6568       }
6569       else if (arg) {
6570         S_localise_gv_slot(aTHX_ (GV *)arg,
6571                                  PL_op->op_private & OPpLVREF_TYPE);
6572       }
6573       else if (!(PL_op->op_private & OPpPAD_STATE))
6574         SAVECLEARSV(PAD_SVl(ARGTARG));
6575     }
6576     XPUSHs(ret);
6577     RETURN;
6578 }
6579
6580 PP(pp_lvrefslice)
6581 {
6582     dSP; dMARK;
6583     AV * const av = (AV *)POPs;
6584     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6585     bool can_preserve = FALSE;
6586
6587     if (UNLIKELY(localizing)) {
6588         MAGIC *mg;
6589         HV *stash;
6590         SV **svp;
6591
6592         can_preserve = SvCANEXISTDELETE(av);
6593
6594         if (SvTYPE(av) == SVt_PVAV) {
6595             SSize_t max = -1;
6596
6597             for (svp = MARK + 1; svp <= SP; svp++) {
6598                 const SSize_t elem = SvIV(*svp);
6599                 if (elem > max)
6600                     max = elem;
6601             }
6602             if (max > AvMAX(av))
6603                 av_extend(av, max);
6604         }
6605     }
6606
6607     while (++MARK <= SP) {
6608         SV * const elemsv = *MARK;
6609         if (SvTYPE(av) == SVt_PVAV)
6610             S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6611         else
6612             S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6613         *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6614         sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6615     }
6616     RETURN;
6617 }
6618
6619 PP(pp_lvavref)
6620 {
6621     if (PL_op->op_flags & OPf_STACKED)
6622         Perl_pp_rv2av(aTHX);
6623     else
6624         Perl_pp_padav(aTHX);
6625     {
6626         dSP;
6627         dTOPss;
6628         SETs(0); /* special alias marker that aassign recognises */
6629         XPUSHs(sv);
6630         RETURN;
6631     }
6632 }
6633
6634 PP(pp_anonconst)
6635 {
6636     dSP;
6637     dTOPss;
6638     SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6639                                         ? CopSTASH(PL_curcop)
6640                                         : NULL,
6641                                       NULL, SvREFCNT_inc_simple_NN(sv))));
6642     RETURN;
6643 }
6644
6645
6646 /* process one subroutine argument - typically when the sub has a signature:
6647  * introduce PL_curpad[op_targ] and assign to it the value
6648  *  for $:   (OPf_STACKED ? *sp : $_[N])
6649  *  for @/%: @_[N..$#_]
6650  *
6651  * It's equivalent to
6652  *    my $foo = $_[N];
6653  * or
6654  *    my $foo = (value-on-stack)
6655  * or
6656  *    my @foo = @_[N..$#_]
6657  * etc
6658  */
6659
6660 PP(pp_argelem)
6661 {
6662     dTARG;
6663     SV *val;
6664     SV ** padentry;
6665     OP *o = PL_op;
6666     AV *defav = GvAV(PL_defgv); /* @_ */
6667     IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6668     IV argc;
6669
6670     /* do 'my $var, @var or %var' action */
6671     padentry = &(PAD_SVl(o->op_targ));
6672     save_clearsv(padentry);
6673     targ = *padentry;
6674
6675     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6676         if (o->op_flags & OPf_STACKED) {
6677             dSP;
6678             val = POPs;
6679             PUTBACK;
6680         }
6681         else {
6682             SV **svp;
6683             /* should already have been checked */
6684             assert(ix >= 0);
6685 #if IVSIZE > PTRSIZE
6686             assert(ix <= SSize_t_MAX);
6687 #endif
6688
6689             svp = av_fetch(defav, ix, FALSE);
6690             val = svp ? *svp : &PL_sv_undef;
6691         }
6692
6693         /* $var = $val */
6694
6695         /* cargo-culted from pp_sassign */
6696         assert(TAINTING_get || !TAINT_get);
6697         if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6698             TAINT_NOT;
6699
6700         SvSetMagicSV(targ, val);
6701         return o->op_next;
6702     }
6703
6704     /* must be AV or HV */
6705
6706     assert(!(o->op_flags & OPf_STACKED));
6707     argc = ((IV)AvFILL(defav) + 1) - ix;
6708
6709     /* This is a copy of the relevant parts of pp_aassign().
6710      */
6711     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6712         IV i;
6713
6714         if (AvFILL((AV*)targ) > -1) {
6715             /* target should usually be empty. If we get get
6716              * here, someone's been doing some weird closure tricks.
6717              * Make a copy of all args before clearing the array,
6718              * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6719              * elements. See similar code in pp_aassign.
6720              */
6721             for (i = 0; i < argc; i++) {
6722                 SV **svp = av_fetch(defav, ix + i, FALSE);
6723                 SV *newsv = newSV(0);
6724                 sv_setsv_flags(newsv,
6725                                 svp ? *svp : &PL_sv_undef,
6726                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6727                 if (!av_store(defav, ix + i, newsv))
6728                     SvREFCNT_dec_NN(newsv);
6729             }
6730             av_clear((AV*)targ);
6731         }
6732
6733         if (argc <= 0)
6734             return o->op_next;
6735
6736         av_extend((AV*)targ, argc);
6737
6738         i = 0;
6739         while (argc--) {
6740             SV *tmpsv;
6741             SV **svp = av_fetch(defav, ix + i, FALSE);
6742             SV *val = svp ? *svp : &PL_sv_undef;
6743             tmpsv = newSV(0);
6744             sv_setsv(tmpsv, val);
6745             av_store((AV*)targ, i++, tmpsv);
6746             TAINT_NOT;
6747         }
6748
6749     }
6750     else {
6751         IV i;
6752
6753         assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
6754
6755         if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
6756             /* see "target should usually be empty" comment above */
6757             for (i = 0; i < argc; i++) {
6758                 SV **svp = av_fetch(defav, ix + i, FALSE);
6759                 SV *newsv = newSV(0);
6760                 sv_setsv_flags(newsv,
6761                                 svp ? *svp : &PL_sv_undef,
6762                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6763                 if (!av_store(defav, ix + i, newsv))
6764                     SvREFCNT_dec_NN(newsv);
6765             }
6766             hv_clear((HV*)targ);
6767         }
6768
6769         if (argc <= 0)
6770             return o->op_next;
6771         assert(argc % 2 == 0);
6772
6773         i = 0;
6774         while (argc) {
6775             SV *tmpsv;
6776             SV **svp;
6777             SV *key;
6778             SV *val;
6779
6780             svp = av_fetch(defav, ix + i++, FALSE);
6781             key = svp ? *svp : &PL_sv_undef;
6782             svp = av_fetch(defav, ix + i++, FALSE);
6783             val = svp ? *svp : &PL_sv_undef;
6784
6785             argc -= 2;
6786             if (UNLIKELY(SvGMAGICAL(key)))
6787                 key = sv_mortalcopy(key);
6788             tmpsv = newSV(0);
6789             sv_setsv(tmpsv, val);
6790             hv_store_ent((HV*)targ, key, tmpsv, 0);
6791             TAINT_NOT;
6792         }
6793     }
6794
6795     return o->op_next;
6796 }
6797
6798 /* Handle a default value for one subroutine argument (typically as part
6799  * of a subroutine signature).
6800  * It's equivalent to
6801  *    @_ > op_targ ? $_[op_targ] : result_of(op_other)
6802  *
6803  * Intended to be used where op_next is an OP_ARGELEM
6804  *
6805  * We abuse the op_targ field slightly: it's an index into @_ rather than
6806  * into PL_curpad.
6807  */
6808
6809 PP(pp_argdefelem)
6810 {
6811     OP * const o = PL_op;
6812     AV *defav = GvAV(PL_defgv); /* @_ */
6813     IV ix = (IV)o->op_targ;
6814
6815     assert(ix >= 0);
6816 #if IVSIZE > PTRSIZE
6817     assert(ix <= SSize_t_MAX);
6818 #endif
6819
6820     if (AvFILL(defav) >= ix) {
6821         dSP;
6822         SV **svp = av_fetch(defav, ix, FALSE);
6823         SV  *val = svp ? *svp : &PL_sv_undef;
6824         XPUSHs(val);
6825         RETURN;
6826     }
6827     return cLOGOPo->op_other;
6828 }
6829
6830
6831 static SV *
6832 S_find_runcv_name(void)
6833 {
6834     dTHX;
6835     CV *cv;
6836     GV *gv;
6837     SV *sv;
6838
6839     cv = find_runcv(0);
6840     if (!cv)
6841         return &PL_sv_no;
6842
6843     gv = CvGV(cv);
6844     if (!gv)
6845         return &PL_sv_no;
6846
6847     sv = sv_2mortal(newSV(0));
6848     gv_fullname4(sv, gv, NULL, TRUE);
6849     return sv;
6850 }
6851
6852 /* Check a  a subs arguments - i.e. that it has the correct number of args
6853  * (and anything else we might think of in future). Typically used with
6854  * signatured subs.
6855  */
6856
6857 PP(pp_argcheck)
6858 {
6859     OP * const o       = PL_op;
6860     UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
6861     IV   params        = aux[0].iv;
6862     IV   opt_params    = aux[1].iv;
6863     char slurpy        = (char)(aux[2].iv);
6864     AV  *defav         = GvAV(PL_defgv); /* @_ */
6865     IV   argc;
6866     bool too_few;
6867
6868     assert(!SvMAGICAL(defav));
6869     argc = (AvFILLp(defav) + 1);
6870     too_few = (argc < (params - opt_params));
6871
6872     if (UNLIKELY(too_few || (!slurpy && argc > params)))
6873         /* diag_listed_as: Too few arguments for subroutine '%s' */
6874         /* diag_listed_as: Too many arguments for subroutine '%s' */
6875         Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
6876                           too_few ? "few" : "many", S_find_runcv_name());
6877
6878     if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
6879         /* diag_listed_as: Odd name/value argument for subroutine '%s' */
6880         Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
6881                           S_find_runcv_name());
6882
6883     return NORMAL;
6884 }
6885
6886 /*
6887  * ex: set ts=8 sts=4 sw=4 et:
6888  */