pp.c

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