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