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