pp.c

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