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 #ifdef NV_NAN
2969       NV result = NV_NAN;
2970 #else
2971       NV result = 0.0;
2972 #endif
2973       if (neg_report) { /* log or sqrt */
2974           if (
2975 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2976               ! Perl_isnan(value) &&
2977 #endif
2978               (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2979               SET_NUMERIC_STANDARD();
2980               /* diag_listed_as: Can't take log of %g */
2981               DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2982           }
2983       }
2984       switch (op_type) {
2985       default:
2986       case OP_SIN:  result = Perl_sin(value);  break;
2987       case OP_COS:  result = Perl_cos(value);  break;
2988       case OP_EXP:  result = Perl_exp(value);  break;
2989       case OP_LOG:  result = Perl_log(value);  break;
2990       case OP_SQRT: result = Perl_sqrt(value); break;
2991       }
2992       SETn(result);
2993       return NORMAL;
2994     }
2995 }
2996
2997 /* Support Configure command-line overrides for rand() functions.
2998    After 5.005, perhaps we should replace this by Configure support
2999    for drand48(), random(), or rand().  For 5.005, though, maintain
3000    compatibility by calling rand() but allow the user to override it.
3001    See INSTALL for details.  --Andy Dougherty  15 July 1998
3002 */
3003 /* Now it's after 5.005, and Configure supports drand48() and random(),
3004    in addition to rand().  So the overrides should not be needed any more.
3005    --Jarkko Hietaniemi  27 September 1998
3006  */
3007
3008 PP(pp_rand)
3009 {
3010     if (!PL_srand_called) {
3011         (void)seedDrand01((Rand_seed_t)seed());
3012         PL_srand_called = TRUE;
3013     }
3014     {
3015         dSP;
3016         NV value;
3017
3018         if (MAXARG < 1)
3019         {
3020             EXTEND(SP, 1);
3021             value = 1.0;
3022         }
3023         else {
3024             SV * const sv = POPs;
3025             if(!sv)
3026                 value = 1.0;
3027             else
3028                 value = SvNV(sv);
3029         }
3030     /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
3031 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3032         if (! Perl_isnan(value) && value == 0.0)
3033 #else
3034         if (value == 0.0)
3035 #endif
3036             value = 1.0;
3037         {
3038             dTARGET;
3039             PUSHs(TARG);
3040             PUTBACK;
3041             value *= Drand01();
3042             sv_setnv_mg(TARG, value);
3043         }
3044     }
3045     return NORMAL;
3046 }
3047
3048 PP(pp_srand)
3049 {
3050     dSP; dTARGET;
3051     UV anum;
3052
3053     if (MAXARG >= 1 && (TOPs || POPs)) {
3054         SV *top;
3055         char *pv;
3056         STRLEN len;
3057         int flags;
3058
3059         top = POPs;
3060         pv = SvPV(top, len);
3061         flags = grok_number(pv, len, &anum);
3062
3063         if (!(flags & IS_NUMBER_IN_UV)) {
3064             Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
3065                              "Integer overflow in srand");
3066             anum = UV_MAX;
3067         }
3068     }
3069     else {
3070         anum = seed();
3071     }
3072
3073     (void)seedDrand01((Rand_seed_t)anum);
3074     PL_srand_called = TRUE;
3075     if (anum)
3076         XPUSHu(anum);
3077     else {
3078         /* Historically srand always returned true. We can avoid breaking
3079            that like this:  */
3080         sv_setpvs(TARG, "0 but true");
3081         XPUSHTARG;
3082     }
3083     RETURN;
3084 }
3085
3086 PP(pp_int)
3087 {
3088     dSP; dTARGET;
3089     tryAMAGICun_MG(int_amg, AMGf_numeric);
3090     {
3091       SV * const sv = TOPs;
3092       const IV iv = SvIV_nomg(sv);
3093       /* XXX it's arguable that compiler casting to IV might be subtly
3094          different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3095          else preferring IV has introduced a subtle behaviour change bug. OTOH
3096          relying on floating point to be accurate is a bug.  */
3097
3098       if (!SvOK(sv)) {
3099         SETu(0);
3100       }
3101       else if (SvIOK(sv)) {
3102         if (SvIsUV(sv))
3103             SETu(SvUV_nomg(sv));
3104         else
3105             SETi(iv);
3106       }
3107       else {
3108           const NV value = SvNV_nomg(sv);
3109           if (UNLIKELY(Perl_isinfnan(value)))
3110               SETn(value);
3111           else if (value >= 0.0) {
3112               if (value < (NV)UV_MAX + 0.5) {
3113                   SETu(U_V(value));
3114               } else {
3115                   SETn(Perl_floor(value));
3116               }
3117           }
3118           else {
3119               if (value > (NV)IV_MIN - 0.5) {
3120                   SETi(I_V(value));
3121               } else {
3122                   SETn(Perl_ceil(value));
3123               }
3124           }
3125       }
3126     }
3127     return NORMAL;
3128 }
3129
3130 PP(pp_abs)
3131 {
3132     dSP; dTARGET;
3133     tryAMAGICun_MG(abs_amg, AMGf_numeric);
3134     {
3135       SV * const sv = TOPs;
3136       /* This will cache the NV value if string isn't actually integer  */
3137       const IV iv = SvIV_nomg(sv);
3138
3139       if (!SvOK(sv)) {
3140         SETu(0);
3141       }
3142       else if (SvIOK(sv)) {
3143         /* IVX is precise  */
3144         if (SvIsUV(sv)) {
3145           SETu(SvUV_nomg(sv));  /* force it to be numeric only */
3146         } else {
3147           if (iv >= 0) {
3148             SETi(iv);
3149           } else {
3150             if (iv != IV_MIN) {
3151               SETi(-iv);
3152             } else {
3153               /* 2s complement assumption. Also, not really needed as
3154                  IV_MIN and -IV_MIN should both be %100...00 and NV-able  */
3155               SETu((UV)IV_MIN);
3156             }
3157           }
3158         }
3159       } else{
3160         const NV value = SvNV_nomg(sv);
3161         if (value < 0.0)
3162           SETn(-value);
3163         else
3164           SETn(value);
3165       }
3166     }
3167     return NORMAL;
3168 }
3169
3170
3171 /* also used for: pp_hex() */
3172
3173 PP(pp_oct)
3174 {
3175     dSP; dTARGET;
3176     const char *tmps;
3177     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3178     STRLEN len;
3179     NV result_nv;
3180     UV result_uv;
3181     SV* const sv = TOPs;
3182
3183     tmps = (SvPV_const(sv, len));
3184     if (DO_UTF8(sv)) {
3185          /* If Unicode, try to downgrade
3186           * If not possible, croak. */
3187          SV* const tsv = sv_2mortal(newSVsv(sv));
3188
3189          SvUTF8_on(tsv);
3190          sv_utf8_downgrade(tsv, FALSE);
3191          tmps = SvPV_const(tsv, len);
3192     }
3193     if (PL_op->op_type == OP_HEX)
3194         goto hex;
3195
3196     while (*tmps && len && isSPACE(*tmps))
3197         tmps++, len--;
3198     if (*tmps == '0')
3199         tmps++, len--;
3200     if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3201     hex:
3202         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3203     }
3204     else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3205         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3206     else
3207         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3208
3209     if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3210         SETn(result_nv);
3211     }
3212     else {
3213         SETu(result_uv);
3214     }
3215     return NORMAL;
3216 }
3217
3218 /* String stuff. */
3219
3220 PP(pp_length)
3221 {
3222     dSP; dTARGET;
3223     SV * const sv = TOPs;
3224
3225     U32 in_bytes = IN_BYTES;
3226     /* simplest case shortcut */
3227     /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
3228     U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3229     STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
3230     SETs(TARG);
3231
3232     if(LIKELY(svflags == SVf_POK))
3233         goto simple_pv;
3234     if(svflags & SVs_GMG)
3235         mg_get(sv);
3236     if (SvOK(sv)) {
3237         if (!IN_BYTES) /* reread to avoid using an C auto/register */
3238             sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
3239         else
3240         {
3241             STRLEN len;
3242             /* unrolled SvPV_nomg_const(sv,len) */
3243             if(SvPOK_nog(sv)){
3244                 simple_pv:
3245                 len = SvCUR(sv);
3246             } else  {
3247                 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3248             }
3249             sv_setiv(TARG, (IV)(len));
3250         }
3251     } else {
3252         if (!SvPADTMP(TARG)) {
3253             sv_setsv_nomg(TARG, &PL_sv_undef);
3254         } else { /* TARG is on stack at this point and is overwriten by SETs.
3255                    This branch is the odd one out, so put TARG by default on
3256                    stack earlier to let local SP go out of liveness sooner */
3257             SETs(&PL_sv_undef);
3258             goto no_set_magic;
3259         }
3260     }
3261     SvSETMAGIC(TARG);
3262     no_set_magic:
3263     return NORMAL; /* no putback, SP didn't move in this opcode */
3264 }
3265
3266 /* Returns false if substring is completely outside original string.
3267    No length is indicated by len_iv = 0 and len_is_uv = 0.  len_is_uv must
3268    always be true for an explicit 0.
3269 */
3270 bool
3271 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3272                                 bool pos1_is_uv, IV len_iv,
3273                                 bool len_is_uv, STRLEN *posp,
3274                                 STRLEN *lenp)
3275 {
3276     IV pos2_iv;
3277     int    pos2_is_uv;
3278
3279     PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3280
3281     if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3282         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3283         pos1_iv += curlen;
3284     }
3285     if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3286         return FALSE;
3287
3288     if (len_iv || len_is_uv) {
3289         if (!len_is_uv && len_iv < 0) {
3290             pos2_iv = curlen + len_iv;
3291             if (curlen)
3292                 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3293             else
3294                 pos2_is_uv = 0;
3295         } else {  /* len_iv >= 0 */
3296             if (!pos1_is_uv && pos1_iv < 0) {
3297                 pos2_iv = pos1_iv + len_iv;
3298                 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3299             } else {
3300                 if ((UV)len_iv > curlen-(UV)pos1_iv)
3301                     pos2_iv = curlen;
3302                 else
3303                     pos2_iv = pos1_iv+len_iv;
3304                 pos2_is_uv = 1;
3305             }
3306         }
3307     }
3308     else {
3309         pos2_iv = curlen;
3310         pos2_is_uv = 1;
3311     }
3312
3313     if (!pos2_is_uv && pos2_iv < 0) {
3314         if (!pos1_is_uv && pos1_iv < 0)
3315             return FALSE;
3316         pos2_iv = 0;
3317     }
3318     else if (!pos1_is_uv && pos1_iv < 0)
3319         pos1_iv = 0;
3320
3321     if ((UV)pos2_iv < (UV)pos1_iv)
3322         pos2_iv = pos1_iv;
3323     if ((UV)pos2_iv > curlen)
3324         pos2_iv = curlen;
3325
3326     /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3327     *posp = (STRLEN)( (UV)pos1_iv );
3328     *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3329
3330     return TRUE;
3331 }
3332
3333 PP(pp_substr)
3334 {
3335     dSP; dTARGET;
3336     SV *sv;
3337     STRLEN curlen;
3338     STRLEN utf8_curlen;
3339     SV *   pos_sv;
3340     IV     pos1_iv;
3341     int    pos1_is_uv;
3342     SV *   len_sv;
3343     IV     len_iv = 0;
3344     int    len_is_uv = 0;
3345     I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3346     const bool rvalue = (GIMME_V != G_VOID);
3347     const char *tmps;
3348     SV *repl_sv = NULL;
3349     const char *repl = NULL;
3350     STRLEN repl_len;
3351     int num_args = PL_op->op_private & 7;
3352     bool repl_need_utf8_upgrade = FALSE;
3353
3354     if (num_args > 2) {
3355         if (num_args > 3) {
3356           if(!(repl_sv = POPs)) num_args--;
3357         }
3358         if ((len_sv = POPs)) {
3359             len_iv    = SvIV(len_sv);
3360             len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3361         }
3362         else num_args--;
3363     }
3364     pos_sv     = POPs;
3365     pos1_iv    = SvIV(pos_sv);
3366     pos1_is_uv = SvIOK_UV(pos_sv);
3367     sv = POPs;
3368     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3369         assert(!repl_sv);
3370         repl_sv = POPs;
3371     }
3372     if (lvalue && !repl_sv) {
3373         SV * ret;
3374         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3375         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3376         LvTYPE(ret) = 'x';
3377         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3378         LvTARGOFF(ret) =
3379             pos1_is_uv || pos1_iv >= 0
3380                 ? (STRLEN)(UV)pos1_iv
3381                 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3382         LvTARGLEN(ret) =
3383             len_is_uv || len_iv > 0
3384                 ? (STRLEN)(UV)len_iv
3385                 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3386
3387         PUSHs(ret);    /* avoid SvSETMAGIC here */
3388         RETURN;
3389     }
3390     if (repl_sv) {
3391         repl = SvPV_const(repl_sv, repl_len);
3392         SvGETMAGIC(sv);
3393         if (SvROK(sv))
3394             Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3395                             "Attempt to use reference as lvalue in substr"
3396             );
3397         tmps = SvPV_force_nomg(sv, curlen);
3398         if (DO_UTF8(repl_sv) && repl_len) {
3399             if (!DO_UTF8(sv)) {
3400                 sv_utf8_upgrade_nomg(sv);
3401                 curlen = SvCUR(sv);
3402             }
3403         }
3404         else if (DO_UTF8(sv))
3405             repl_need_utf8_upgrade = TRUE;
3406     }
3407     else tmps = SvPV_const(sv, curlen);
3408     if (DO_UTF8(sv)) {
3409         utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3410         if (utf8_curlen == curlen)
3411             utf8_curlen = 0;
3412         else
3413             curlen = utf8_curlen;
3414     }
3415     else
3416         utf8_curlen = 0;
3417
3418     {
3419         STRLEN pos, len, byte_len, byte_pos;
3420
3421         if (!translate_substr_offsets(
3422                 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3423         )) goto bound_fail;
3424
3425         byte_len = len;
3426         byte_pos = utf8_curlen
3427             ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3428
3429         tmps += byte_pos;
3430
3431         if (rvalue) {
3432             SvTAINTED_off(TARG);                        /* decontaminate */
3433             SvUTF8_off(TARG);                   /* decontaminate */
3434             sv_setpvn(TARG, tmps, byte_len);
3435 #ifdef USE_LOCALE_COLLATE
3436             sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3437 #endif
3438             if (utf8_curlen)
3439                 SvUTF8_on(TARG);
3440         }
3441
3442         if (repl) {
3443             SV* repl_sv_copy = NULL;
3444
3445             if (repl_need_utf8_upgrade) {
3446                 repl_sv_copy = newSVsv(repl_sv);
3447                 sv_utf8_upgrade(repl_sv_copy);
3448                 repl = SvPV_const(repl_sv_copy, repl_len);
3449             }
3450             if (!SvOK(sv))
3451                 sv_setpvs(sv, "");
3452             sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3453             SvREFCNT_dec(repl_sv_copy);
3454         }
3455     }
3456     if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3457         SP++;
3458     else if (rvalue) {
3459         SvSETMAGIC(TARG);
3460         PUSHs(TARG);
3461     }
3462     RETURN;
3463
3464   bound_fail:
3465     if (repl)
3466         Perl_croak(aTHX_ "substr outside of string");
3467     Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3468     RETPUSHUNDEF;
3469 }
3470
3471 PP(pp_vec)
3472 {
3473     dSP;
3474     const IV size   = POPi;
3475     const IV offset = POPi;
3476     SV * const src = POPs;
3477     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3478     SV * ret;
3479
3480     if (lvalue) {                       /* it's an lvalue! */
3481         ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
3482         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3483         LvTYPE(ret) = 'v';
3484         LvTARG(ret) = SvREFCNT_inc_simple(src);
3485         LvTARGOFF(ret) = offset;
3486         LvTARGLEN(ret) = size;
3487     }
3488     else {
3489         dTARGET;
3490         SvTAINTED_off(TARG);            /* decontaminate */
3491         ret = TARG;
3492     }
3493
3494     sv_setuv(ret, do_vecget(src, offset, size));
3495     if (!lvalue)
3496         SvSETMAGIC(ret);
3497     PUSHs(ret);
3498     RETURN;
3499 }
3500
3501
3502 /* also used for: pp_rindex() */
3503
3504 PP(pp_index)
3505 {
3506     dSP; dTARGET;
3507     SV *big;
3508     SV *little;
3509     SV *temp = NULL;
3510     STRLEN biglen;
3511     STRLEN llen = 0;
3512     SSize_t offset = 0;
3513     SSize_t retval;
3514     const char *big_p;
3515     const char *little_p;
3516     bool big_utf8;
3517     bool little_utf8;
3518     const bool is_index = PL_op->op_type == OP_INDEX;
3519     const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3520
3521     if (threeargs)
3522         offset = POPi;
3523     little = POPs;
3524     big = POPs;
3525     big_p = SvPV_const(big, biglen);
3526     little_p = SvPV_const(little, llen);
3527
3528     big_utf8 = DO_UTF8(big);
3529     little_utf8 = DO_UTF8(little);
3530     if (big_utf8 ^ little_utf8) {
3531         /* One needs to be upgraded.  */
3532         if (little_utf8) {
3533             /* Well, maybe instead we might be able to downgrade the small
3534                string?  */
3535             char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3536                                                      &little_utf8);
3537             if (little_utf8) {
3538                 /* If the large string is ISO-8859-1, and it's not possible to
3539                    convert the small string to ISO-8859-1, then there is no
3540                    way that it could be found anywhere by index.  */
3541                 retval = -1;
3542                 goto fail;
3543             }
3544
3545             /* At this point, pv is a malloc()ed string. So donate it to temp
3546                to ensure it will get free()d  */
3547             little = temp = newSV(0);
3548             sv_usepvn(temp, pv, llen);
3549             little_p = SvPVX(little);
3550         } else {
3551             temp = newSVpvn(little_p, llen);
3552
3553             sv_utf8_upgrade(temp);
3554             little = temp;
3555             little_p = SvPV_const(little, llen);
3556         }
3557     }
3558     if (SvGAMAGIC(big)) {
3559         /* Life just becomes a lot easier if I use a temporary here.
3560            Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3561            will trigger magic and overloading again, as will fbm_instr()
3562         */
3563         big = newSVpvn_flags(big_p, biglen,
3564                              SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3565         big_p = SvPVX(big);
3566     }
3567     if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3568         /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3569            warn on undef, and we've already triggered a warning with the
3570            SvPV_const some lines above. We can't remove that, as we need to
3571            call some SvPV to trigger overloading early and find out if the
3572            string is UTF-8.
3573            This is all getting too messy. The API isn't quite clean enough,
3574            because data access has side effects.
3575         */
3576         little = newSVpvn_flags(little_p, llen,
3577                                 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3578         little_p = SvPVX(little);
3579     }
3580
3581     if (!threeargs)
3582         offset = is_index ? 0 : biglen;
3583     else {
3584         if (big_utf8 && offset > 0)
3585             offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3586         if (!is_index)
3587             offset += llen;
3588     }
3589     if (offset < 0)
3590         offset = 0;
3591     else if (offset > (SSize_t)biglen)
3592         offset = biglen;
3593     if (!(little_p = is_index
3594           ? fbm_instr((unsigned char*)big_p + offset,
3595                       (unsigned char*)big_p + biglen, little, 0)
3596           : rninstr(big_p,  big_p  + offset,
3597                     little_p, little_p + llen)))
3598         retval = -1;
3599     else {
3600         retval = little_p - big_p;
3601         if (retval > 1 && big_utf8)
3602             retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3603     }
3604     SvREFCNT_dec(temp);
3605  fail:
3606     PUSHi(retval);
3607     RETURN;
3608 }
3609
3610 PP(pp_sprintf)
3611 {
3612     dSP; dMARK; dORIGMARK; dTARGET;
3613     SvTAINTED_off(TARG);
3614     do_sprintf(TARG, SP-MARK, MARK+1);
3615     TAINT_IF(SvTAINTED(TARG));
3616     SP = ORIGMARK;
3617     PUSHTARG;
3618     RETURN;
3619 }
3620
3621 PP(pp_ord)
3622 {
3623     dSP; dTARGET;
3624
3625     SV *argsv = TOPs;
3626     STRLEN len;
3627     const U8 *s = (U8*)SvPV_const(argsv, len);
3628
3629     SETu(DO_UTF8(argsv)
3630            ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3631            : (UV)(*s));
3632
3633     return NORMAL;
3634 }
3635
3636 PP(pp_chr)
3637 {
3638     dSP; dTARGET;
3639     char *tmps;
3640     UV value;
3641     SV *top = TOPs;
3642
3643     SvGETMAGIC(top);
3644     if (UNLIKELY(SvAMAGIC(top)))
3645         top = sv_2num(top);
3646     if (UNLIKELY(isinfnansv(top)))
3647         Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3648     else {
3649         if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3650             && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3651                 ||
3652                 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3653                  && SvNV_nomg(top) < 0.0)))
3654         {
3655             if (ckWARN(WARN_UTF8)) {
3656                 if (SvGMAGICAL(top)) {
3657                     SV *top2 = sv_newmortal();
3658                     sv_setsv_nomg(top2, top);
3659                     top = top2;
3660                 }
3661                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3662                             "Invalid negative number (%"SVf") in chr", SVfARG(top));
3663             }
3664             value = UNICODE_REPLACEMENT;
3665         } else {
3666             value = SvUV_nomg(top);
3667         }
3668     }
3669
3670     SvUPGRADE(TARG,SVt_PV);
3671
3672     if (value > 255 && !IN_BYTES) {
3673         SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3674         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3675         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3676         *tmps = '\0';
3677         (void)SvPOK_only(TARG);
3678         SvUTF8_on(TARG);
3679         SETTARG;
3680         return NORMAL;
3681     }
3682
3683     SvGROW(TARG,2);
3684     SvCUR_set(TARG, 1);
3685     tmps = SvPVX(TARG);
3686     *tmps++ = (char)value;
3687     *tmps = '\0';
3688     (void)SvPOK_only(TARG);
3689
3690     SETTARG;
3691     return NORMAL;
3692 }
3693
3694 PP(pp_crypt)
3695 {
3696 #ifdef HAS_CRYPT
3697     dSP; dTARGET;
3698     dPOPTOPssrl;
3699     STRLEN len;
3700     const char *tmps = SvPV_const(left, len);
3701
3702     if (DO_UTF8(left)) {
3703          /* If Unicode, try to downgrade.
3704           * If not possible, croak.
3705           * Yes, we made this up.  */
3706          SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3707
3708          sv_utf8_downgrade(tsv, FALSE);
3709          tmps = SvPV_const(tsv, len);
3710     }
3711 #   ifdef USE_ITHREADS
3712 #     ifdef HAS_CRYPT_R
3713     if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3714       /* This should be threadsafe because in ithreads there is only
3715        * one thread per interpreter.  If this would not be true,
3716        * we would need a mutex to protect this malloc. */
3717         PL_reentrant_buffer->_crypt_struct_buffer =
3718           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3719 #if defined(__GLIBC__) || defined(__EMX__)
3720         if (PL_reentrant_buffer->_crypt_struct_buffer) {
3721             PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3722             /* work around glibc-2.2.5 bug */
3723             PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3724         }
3725 #endif
3726     }
3727 #     endif /* HAS_CRYPT_R */
3728 #   endif /* USE_ITHREADS */
3729 #   ifdef FCRYPT
3730     sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3731 #   else
3732     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3733 #   endif
3734     SvUTF8_off(TARG);
3735     SETTARG;
3736     RETURN;
3737 #else
3738     DIE(aTHX_
3739       "The crypt() function is unimplemented due to excessive paranoia.");
3740 #endif
3741 }
3742
3743 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level.  So
3744  * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3745
3746
3747 /* also used for: pp_lcfirst() */
3748
3749 PP(pp_ucfirst)
3750 {
3751     /* Actually is both lcfirst() and ucfirst().  Only the first character
3752      * changes.  This means that possibly we can change in-place, ie., just
3753      * take the source and change that one character and store it back, but not
3754      * if read-only etc, or if the length changes */
3755
3756     dSP;
3757     SV *source = TOPs;
3758     STRLEN slen; /* slen is the byte length of the whole SV. */
3759     STRLEN need;
3760     SV *dest;
3761     bool inplace;   /* ? Convert first char only, in-place */
3762     bool doing_utf8 = FALSE;               /* ? using utf8 */
3763     bool convert_source_to_utf8 = FALSE;   /* ? need to convert */
3764     const int op_type = PL_op->op_type;
3765     const U8 *s;
3766     U8 *d;
3767     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3768     STRLEN ulen;    /* ulen is the byte length of the original Unicode character
3769                      * stored as UTF-8 at s. */
3770     STRLEN tculen;  /* tculen is the byte length of the freshly titlecased (or
3771                      * lowercased) character stored in tmpbuf.  May be either
3772                      * UTF-8 or not, but in either case is the number of bytes */
3773
3774     s = (const U8*)SvPV_const(source, slen);
3775
3776     /* We may be able to get away with changing only the first character, in
3777      * place, but not if read-only, etc.  Later we may discover more reasons to
3778      * not convert in-place. */
3779     inplace = !SvREADONLY(source) && SvPADTMP(source);
3780
3781     /* First calculate what the changed first character should be.  This affects
3782      * whether we can just swap it out, leaving the rest of the string unchanged,
3783      * or even if have to convert the dest to UTF-8 when the source isn't */
3784
3785     if (! slen) {   /* If empty */
3786         need = 1; /* still need a trailing NUL */
3787         ulen = 0;
3788     }
3789     else if (DO_UTF8(source)) { /* Is the source utf8? */
3790         doing_utf8 = TRUE;
3791         ulen = UTF8SKIP(s);
3792         if (op_type == OP_UCFIRST) {
3793 #ifdef USE_LOCALE_CTYPE
3794             _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3795 #else
3796             _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3797 #endif
3798         }
3799         else {
3800 #ifdef USE_LOCALE_CTYPE
3801             _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3802 #else
3803             _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3804 #endif
3805         }
3806
3807         /* we can't do in-place if the length changes.  */
3808         if (ulen != tculen) inplace = FALSE;
3809         need = slen + 1 - ulen + tculen;
3810     }
3811     else { /* Non-zero length, non-UTF-8,  Need to consider locale and if
3812             * latin1 is treated as caseless.  Note that a locale takes
3813             * precedence */
3814         ulen = 1;       /* Original character is 1 byte */
3815         tculen = 1;     /* Most characters will require one byte, but this will
3816                          * need to be overridden for the tricky ones */
3817         need = slen + 1;
3818
3819         if (op_type == OP_LCFIRST) {
3820
3821             /* lower case the first letter: no trickiness for any character */
3822 #ifdef USE_LOCALE_CTYPE
3823             if (IN_LC_RUNTIME(LC_CTYPE)) {
3824                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3825                 *tmpbuf = toLOWER_LC(*s);
3826             }
3827             else
3828 #endif
3829             {
3830                 *tmpbuf = (IN_UNI_8_BIT)
3831                           ? toLOWER_LATIN1(*s)
3832                           : toLOWER(*s);
3833             }
3834         }
3835 #ifdef USE_LOCALE_CTYPE
3836         /* is ucfirst() */
3837         else if (IN_LC_RUNTIME(LC_CTYPE)) {
3838             if (IN_UTF8_CTYPE_LOCALE) {
3839                 goto do_uni_rules;
3840             }
3841
3842             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3843             *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3844                                               locales have upper and title case
3845                                               different */
3846         }
3847 #endif
3848         else if (! IN_UNI_8_BIT) {
3849             *tmpbuf = toUPPER(*s);      /* Returns caseless for non-ascii, or
3850                                          * on EBCDIC machines whatever the
3851                                          * native function does */
3852         }
3853         else {
3854             /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3855              * UTF-8, which we treat as not in locale), and cased latin1 */
3856             UV title_ord;
3857 #ifdef USE_LOCALE_CTYPE
3858       do_uni_rules:
3859 #endif
3860
3861             title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3862             if (tculen > 1) {
3863                 assert(tculen == 2);
3864
3865                 /* If the result is an upper Latin1-range character, it can
3866                  * still be represented in one byte, which is its ordinal */
3867                 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3868                     *tmpbuf = (U8) title_ord;
3869                     tculen = 1;
3870                 }
3871                 else {
3872                     /* Otherwise it became more than one ASCII character (in
3873                      * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3874                      * beyond Latin1, so the number of bytes changed, so can't
3875                      * replace just the first character in place. */
3876                     inplace = FALSE;
3877
3878                     /* If the result won't fit in a byte, the entire result
3879                      * will have to be in UTF-8.  Assume worst case sizing in
3880                      * conversion. (all latin1 characters occupy at most two
3881                      * bytes in utf8) */
3882                     if (title_ord > 255) {
3883                         doing_utf8 = TRUE;
3884                         convert_source_to_utf8 = TRUE;
3885                         need = slen * 2 + 1;
3886
3887                         /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3888                          * (both) characters whose title case is above 255 is
3889                          * 2. */
3890                         ulen = 2;
3891                     }
3892                     else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3893                         need = slen + 1 + 1;
3894                     }
3895                 }
3896             }
3897         } /* End of use Unicode (Latin1) semantics */
3898     } /* End of changing the case of the first character */
3899
3900     /* Here, have the first character's changed case stored in tmpbuf.  Ready to
3901      * generate the result */
3902     if (inplace) {
3903
3904         /* We can convert in place.  This means we change just the first
3905          * character without disturbing the rest; no need to grow */
3906         dest = source;
3907         s = d = (U8*)SvPV_force_nomg(source, slen);
3908     } else {
3909         dTARGET;
3910
3911         dest = TARG;
3912
3913         /* Here, we can't convert in place; we earlier calculated how much
3914          * space we will need, so grow to accommodate that */
3915         SvUPGRADE(dest, SVt_PV);
3916         d = (U8*)SvGROW(dest, need);
3917         (void)SvPOK_only(dest);
3918
3919         SETs(dest);
3920     }
3921
3922     if (doing_utf8) {
3923         if (! inplace) {
3924             if (! convert_source_to_utf8) {
3925
3926                 /* Here  both source and dest are in UTF-8, but have to create
3927                  * the entire output.  We initialize the result to be the
3928                  * title/lower cased first character, and then append the rest
3929                  * of the string. */
3930                 sv_setpvn(dest, (char*)tmpbuf, tculen);
3931                 if (slen > ulen) {
3932                     sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3933                 }
3934             }
3935             else {
3936                 const U8 *const send = s + slen;
3937
3938                 /* Here the dest needs to be in UTF-8, but the source isn't,
3939                  * except we earlier UTF-8'd the first character of the source
3940                  * into tmpbuf.  First put that into dest, and then append the
3941                  * rest of the source, converting it to UTF-8 as we go. */
3942
3943                 /* Assert tculen is 2 here because the only two characters that
3944                  * get to this part of the code have 2-byte UTF-8 equivalents */
3945                 *d++ = *tmpbuf;
3946                 *d++ = *(tmpbuf + 1);
3947                 s++;    /* We have just processed the 1st char */
3948
3949                 for (; s < send; s++) {
3950                     d = uvchr_to_utf8(d, *s);
3951                 }
3952                 *d = '\0';
3953                 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3954             }
3955             SvUTF8_on(dest);
3956         }
3957         else {   /* in-place UTF-8.  Just overwrite the first character */
3958             Copy(tmpbuf, d, tculen, U8);
3959             SvCUR_set(dest, need - 1);
3960         }
3961
3962     }
3963     else {  /* Neither source nor dest are in or need to be UTF-8 */
3964         if (slen) {
3965             if (inplace) {  /* in-place, only need to change the 1st char */
3966                 *d = *tmpbuf;
3967             }
3968             else {      /* Not in-place */
3969
3970                 /* Copy the case-changed character(s) from tmpbuf */
3971                 Copy(tmpbuf, d, tculen, U8);
3972                 d += tculen - 1; /* Code below expects d to point to final
3973                                   * character stored */
3974             }
3975         }
3976         else {  /* empty source */
3977             /* See bug #39028: Don't taint if empty  */
3978             *d = *s;
3979         }
3980
3981         /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3982          * the destination to retain that flag */
3983         if (SvUTF8(source) && ! IN_BYTES)
3984             SvUTF8_on(dest);
3985
3986         if (!inplace) { /* Finish the rest of the string, unchanged */
3987             /* This will copy the trailing NUL  */
3988             Copy(s + 1, d + 1, slen, U8);
3989             SvCUR_set(dest, need - 1);
3990         }
3991     }
3992 #ifdef USE_LOCALE_CTYPE
3993     if (IN_LC_RUNTIME(LC_CTYPE)) {
3994         TAINT;
3995         SvTAINTED_on(dest);
3996     }
3997 #endif
3998     if (dest != source && SvTAINTED(source))
3999         SvTAINT(dest);
4000     SvSETMAGIC(dest);
4001     return NORMAL;
4002 }
4003
4004 /* There's so much setup/teardown code common between uc and lc, I wonder if
4005    it would be worth merging the two, and just having a switch outside each
4006    of the three tight loops.  There is less and less commonality though */
4007 PP(pp_uc)
4008 {
4009     dSP;
4010     SV *source = TOPs;
4011     STRLEN len;
4012     STRLEN min;
4013     SV *dest;
4014     const U8 *s;
4015     U8 *d;
4016
4017     SvGETMAGIC(source);
4018
4019     if (   SvPADTMP(source)
4020         && !SvREADONLY(source) && SvPOK(source)
4021         && !DO_UTF8(source)
4022         && (
4023 #ifdef USE_LOCALE_CTYPE
4024             (IN_LC_RUNTIME(LC_CTYPE))
4025             ? ! IN_UTF8_CTYPE_LOCALE
4026             :
4027 #endif
4028               ! IN_UNI_8_BIT))
4029     {
4030
4031         /* We can convert in place.  The reason we can't if in UNI_8_BIT is to
4032          * make the loop tight, so we overwrite the source with the dest before
4033          * looking at it, and we need to look at the original source
4034          * afterwards.  There would also need to be code added to handle
4035          * switching to not in-place in midstream if we run into characters
4036          * that change the length.  Since being in locale overrides UNI_8_BIT,
4037          * that latter becomes irrelevant in the above test; instead for
4038          * locale, the size can't normally change, except if the locale is a
4039          * UTF-8 one */
4040         dest = source;
4041         s = d = (U8*)SvPV_force_nomg(source, len);
4042         min = len + 1;
4043     } else {
4044         dTARGET;
4045
4046         dest = TARG;
4047
4048         s = (const U8*)SvPV_nomg_const(source, len);
4049         min = len + 1;
4050
4051         SvUPGRADE(dest, SVt_PV);
4052         d = (U8*)SvGROW(dest, min);
4053         (void)SvPOK_only(dest);
4054
4055         SETs(dest);
4056     }
4057
4058     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4059        to check DO_UTF8 again here.  */
4060
4061     if (DO_UTF8(source)) {
4062         const U8 *const send = s + len;
4063         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4064
4065         /* All occurrences of these are to be moved to follow any other marks.
4066          * This is context-dependent.  We may not be passed enough context to
4067          * move the iota subscript beyond all of them, but we do the best we can
4068          * with what we're given.  The result is always better than if we
4069          * hadn't done this.  And, the problem would only arise if we are
4070          * passed a character without all its combining marks, which would be
4071          * the caller's mistake.  The information this is based on comes from a
4072          * comment in Unicode SpecialCasing.txt, (and the Standard's text
4073          * itself) and so can't be checked properly to see if it ever gets
4074          * revised.  But the likelihood of it changing is remote */
4075         bool in_iota_subscript = FALSE;
4076
4077         while (s < send) {
4078             STRLEN u;
4079             STRLEN ulen;
4080             UV uv;
4081             if (in_iota_subscript && ! _is_utf8_mark(s)) {
4082
4083                 /* A non-mark.  Time to output the iota subscript */
4084                 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4085                 d += capital_iota_len;
4086                 in_iota_subscript = FALSE;
4087             }
4088
4089             /* Then handle the current character.  Get the changed case value
4090              * and copy it to the output buffer */
4091
4092             u = UTF8SKIP(s);
4093 #ifdef USE_LOCALE_CTYPE
4094             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4095 #else
4096             uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
4097 #endif
4098 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4099 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4100             if (uv == GREEK_CAPITAL_LETTER_IOTA
4101                 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4102             {
4103                 in_iota_subscript = TRUE;
4104             }
4105             else {
4106                 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4107                     /* If the eventually required minimum size outgrows the
4108                      * available space, we need to grow. */
4109                     const UV o = d - (U8*)SvPVX_const(dest);
4110
4111                     /* If someone uppercases one million U+03B0s we SvGROW()
4112                      * one million times.  Or we could try guessing how much to
4113                      * allocate without allocating too much.  Such is life.
4114                      * See corresponding comment in lc code for another option
4115                      * */
4116                     d = o + (U8*) SvGROW(dest, min);
4117                 }
4118                 Copy(tmpbuf, d, ulen, U8);
4119                 d += ulen;
4120             }
4121             s += u;
4122         }
4123         if (in_iota_subscript) {
4124             Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
4125             d += capital_iota_len;
4126         }
4127         SvUTF8_on(dest);
4128         *d = '\0';
4129
4130         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4131     }
4132     else {      /* Not UTF-8 */
4133         if (len) {
4134             const U8 *const send = s + len;
4135
4136             /* Use locale casing if in locale; regular style if not treating
4137              * latin1 as having case; otherwise the latin1 casing.  Do the
4138              * whole thing in a tight loop, for speed, */
4139 #ifdef USE_LOCALE_CTYPE
4140             if (IN_LC_RUNTIME(LC_CTYPE)) {
4141                 if (IN_UTF8_CTYPE_LOCALE) {
4142                     goto do_uni_rules;
4143                 }
4144                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4145                 for (; s < send; d++, s++)
4146                     *d = (U8) toUPPER_LC(*s);
4147             }
4148             else
4149 #endif
4150                  if (! IN_UNI_8_BIT) {
4151                 for (; s < send; d++, s++) {
4152                     *d = toUPPER(*s);
4153                 }
4154             }
4155             else {
4156 #ifdef USE_LOCALE_CTYPE
4157           do_uni_rules:
4158 #endif
4159                 for (; s < send; d++, s++) {
4160                     *d = toUPPER_LATIN1_MOD(*s);
4161                     if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
4162                         continue;
4163                     }
4164
4165                     /* The mainstream case is the tight loop above.  To avoid
4166                      * extra tests in that, all three characters that require
4167                      * special handling are mapped by the MOD to the one tested
4168                      * just above.
4169                      * Use the source to distinguish between the three cases */
4170
4171 #if    UNICODE_MAJOR_VERSION > 2                                        \
4172    || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1           \
4173                                   && UNICODE_DOT_DOT_VERSION >= 8)
4174                     if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4175
4176                         /* uc() of this requires 2 characters, but they are
4177                          * ASCII.  If not enough room, grow the string */
4178                         if (SvLEN(dest) < ++min) {
4179                             const UV o = d - (U8*)SvPVX_const(dest);
4180                             d = o + (U8*) SvGROW(dest, min);
4181                         }
4182                         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4183                         continue;   /* Back to the tight loop; still in ASCII */
4184                     }
4185 #endif
4186
4187                     /* The other two special handling characters have their
4188                      * upper cases outside the latin1 range, hence need to be
4189                      * in UTF-8, so the whole result needs to be in UTF-8.  So,
4190                      * here we are somewhere in the middle of processing a
4191                      * non-UTF-8 string, and realize that we will have to convert
4192                      * the whole thing to UTF-8.  What to do?  There are
4193                      * several possibilities.  The simplest to code is to
4194                      * convert what we have so far, set a flag, and continue on
4195                      * in the loop.  The flag would be tested each time through
4196                      * the loop, and if set, the next character would be
4197                      * converted to UTF-8 and stored.  But, I (khw) didn't want
4198                      * to slow down the mainstream case at all for this fairly
4199                      * rare case, so I didn't want to add a test that didn't
4200                      * absolutely have to be there in the loop, besides the
4201                      * possibility that it would get too complicated for
4202                      * optimizers to deal with.  Another possibility is to just
4203                      * give up, convert the source to UTF-8, and restart the
4204                      * function that way.  Another possibility is to convert
4205                      * both what has already been processed and what is yet to
4206                      * come separately to UTF-8, then jump into the loop that
4207                      * handles UTF-8.  But the most efficient time-wise of the
4208                      * ones I could think of is what follows, and turned out to
4209                      * not require much extra code.  */
4210
4211                     /* Convert what we have so far into UTF-8, telling the
4212                      * function that we know it should be converted, and to
4213                      * allow extra space for what we haven't processed yet.
4214                      * Assume the worst case space requirements for converting
4215                      * what we haven't processed so far: that it will require
4216                      * two bytes for each remaining source character, plus the
4217                      * NUL at the end.  This may cause the string pointer to
4218                      * move, so re-find it. */
4219
4220                     len = d - (U8*)SvPVX_const(dest);
4221                     SvCUR_set(dest, len);
4222                     len = sv_utf8_upgrade_flags_grow(dest,
4223                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4224                                                 (send -s) * 2 + 1);
4225                     d = (U8*)SvPVX(dest) + len;
4226
4227                     /* Now process the remainder of the source, converting to
4228                      * upper and UTF-8.  If a resulting byte is invariant in
4229                      * UTF-8, output it as-is, otherwise convert to UTF-8 and
4230                      * append it to the output. */
4231                     for (; s < send; s++) {
4232                         (void) _to_upper_title_latin1(*s, d, &len, 'S');
4233                         d += len;
4234                     }
4235
4236                     /* Here have processed the whole source; no need to continue
4237                      * with the outer loop.  Each character has been converted
4238                      * to upper case and converted to UTF-8 */
4239
4240                     break;
4241                 } /* End of processing all latin1-style chars */
4242             } /* End of processing all chars */
4243         } /* End of source is not empty */
4244
4245         if (source != dest) {
4246             *d = '\0';  /* Here d points to 1 after last char, add NUL */
4247             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4248         }
4249     } /* End of isn't utf8 */
4250 #ifdef USE_LOCALE_CTYPE
4251     if (IN_LC_RUNTIME(LC_CTYPE)) {
4252         TAINT;
4253         SvTAINTED_on(dest);
4254     }
4255 #endif
4256     if (dest != source && SvTAINTED(source))
4257         SvTAINT(dest);
4258     SvSETMAGIC(dest);
4259     return NORMAL;
4260 }
4261
4262 PP(pp_lc)
4263 {
4264     dSP;
4265     SV *source = TOPs;
4266     STRLEN len;
4267     STRLEN min;
4268     SV *dest;
4269     const U8 *s;
4270     U8 *d;
4271
4272     SvGETMAGIC(source);
4273
4274     if (   SvPADTMP(source)
4275         && !SvREADONLY(source) && SvPOK(source)
4276         && !DO_UTF8(source)) {
4277
4278         /* We can convert in place, as lowercasing anything in the latin1 range
4279          * (or else DO_UTF8 would have been on) doesn't lengthen it */
4280         dest = source;
4281         s = d = (U8*)SvPV_force_nomg(source, len);
4282         min = len + 1;
4283     } else {
4284         dTARGET;
4285
4286         dest = TARG;
4287
4288         s = (const U8*)SvPV_nomg_const(source, len);
4289         min = len + 1;
4290
4291         SvUPGRADE(dest, SVt_PV);
4292         d = (U8*)SvGROW(dest, min);
4293         (void)SvPOK_only(dest);
4294
4295         SETs(dest);
4296     }
4297
4298     /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4299        to check DO_UTF8 again here.  */
4300
4301     if (DO_UTF8(source)) {
4302         const U8 *const send = s + len;
4303         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4304
4305         while (s < send) {
4306             const STRLEN u = UTF8SKIP(s);
4307             STRLEN ulen;
4308
4309 #ifdef USE_LOCALE_CTYPE
4310             _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4311 #else
4312             _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4313 #endif
4314
4315             /* Here is where we would do context-sensitive actions.  See the
4316              * commit message for 86510fb15 for why there isn't any */
4317
4318             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4319
4320                 /* If the eventually required minimum size outgrows the
4321                  * available space, we need to grow. */
4322                 const UV o = d - (U8*)SvPVX_const(dest);
4323
4324                 /* If someone lowercases one million U+0130s we SvGROW() one
4325                  * million times.  Or we could try guessing how much to
4326                  * allocate without allocating too much.  Such is life.
4327                  * Another option would be to grow an extra byte or two more
4328                  * each time we need to grow, which would cut down the million
4329                  * to 500K, with little waste */
4330                 d = o + (U8*) SvGROW(dest, min);
4331             }
4332
4333             /* Copy the newly lowercased letter to the output buffer we're
4334              * building */
4335             Copy(tmpbuf, d, ulen, U8);
4336             d += ulen;
4337             s += u;
4338         }   /* End of looping through the source string */
4339         SvUTF8_on(dest);
4340         *d = '\0';
4341         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4342     } else {    /* Not utf8 */
4343         if (len) {
4344             const U8 *const send = s + len;
4345
4346             /* Use locale casing if in locale; regular style if not treating
4347              * latin1 as having case; otherwise the latin1 casing.  Do the
4348              * whole thing in a tight loop, for speed, */
4349 #ifdef USE_LOCALE_CTYPE
4350             if (IN_LC_RUNTIME(LC_CTYPE)) {
4351                 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4352                 for (; s < send; d++, s++)
4353                     *d = toLOWER_LC(*s);
4354             }
4355             else
4356 #endif
4357             if (! IN_UNI_8_BIT) {
4358                 for (; s < send; d++, s++) {
4359                     *d = toLOWER(*s);
4360                 }
4361             }
4362             else {
4363                 for (; s < send; d++, s++) {
4364                     *d = toLOWER_LATIN1(*s);
4365                 }
4366             }
4367         }
4368         if (source != dest) {
4369             *d = '\0';
4370             SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4371         }
4372     }
4373 #ifdef USE_LOCALE_CTYPE
4374     if (IN_LC_RUNTIME(LC_CTYPE)) {
4375         TAINT;
4376         SvTAINTED_on(dest);
4377     }
4378 #endif
4379     if (dest != source && SvTAINTED(source))
4380         SvTAINT(dest);
4381     SvSETMAGIC(dest);
4382     return NORMAL;
4383 }
4384
4385 PP(pp_quotemeta)
4386 {
4387     dSP; dTARGET;
4388     SV * const sv = TOPs;
4389     STRLEN len;
4390     const char *s = SvPV_const(sv,len);
4391
4392     SvUTF8_off(TARG);                           /* decontaminate */
4393     if (len) {
4394         char *d;
4395         SvUPGRADE(TARG, SVt_PV);
4396         SvGROW(TARG, (len * 2) + 1);
4397         d = SvPVX(TARG);
4398         if (DO_UTF8(sv)) {
4399             while (len) {
4400                 STRLEN ulen = UTF8SKIP(s);
4401                 bool to_quote = FALSE;
4402
4403                 if (UTF8_IS_INVARIANT(*s)) {
4404                     if (_isQUOTEMETA(*s)) {
4405                         to_quote = TRUE;
4406                     }
4407                 }
4408                 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4409                     if (
4410 #ifdef USE_LOCALE_CTYPE
4411                     /* In locale, we quote all non-ASCII Latin1 chars.
4412                      * Otherwise use the quoting rules */
4413
4414                     IN_LC_RUNTIME(LC_CTYPE)
4415                         ||
4416 #endif
4417                         _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4418                     {
4419                         to_quote = TRUE;
4420                     }
4421                 }
4422                 else if (is_QUOTEMETA_high(s)) {
4423                     to_quote = TRUE;
4424                 }
4425
4426                 if (to_quote) {
4427                     *d++ = '\\';
4428                 }
4429                 if (ulen > len)
4430                     ulen = len;
4431                 len -= ulen;
4432                 while (ulen--)
4433                     *d++ = *s++;
4434             }
4435             SvUTF8_on(TARG);
4436         }
4437         else if (IN_UNI_8_BIT) {
4438             while (len--) {
4439                 if (_isQUOTEMETA(*s))
4440                     *d++ = '\\';
4441                 *d++ = *s++;
4442             }
4443         }
4444         else {
4445             /* For non UNI_8_BIT (and hence in locale) just quote all \W
4446              * including everything above ASCII */
4447             while (len--) {
4448                 if (!isWORDCHAR_A(*s))
4449                     *d++ = '\\';
4450                 *d++ = *s++;
4451             }
4452         }
4453         *d = '\0';
4454         SvCUR_set(TARG, d - SvPVX_const(TARG));
4455         (void)SvPOK_only_UTF8(TARG);
4456     }
4457     else
4458         sv_setpvn(TARG, s, len);
4459     SETTARG;
4460     return NORMAL;
4461 }
4462
4463 PP(pp_fc)
4464 {
4465     dTARGET;
4466     dSP;
4467     SV *source = TOPs;
4468     STRLEN len;
4469     STRLEN min;
4470     SV *dest;
4471     const U8 *s;
4472     const U8 *send;
4473     U8 *d;
4474     U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4475 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4476    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4477                                       || UNICODE_DOT_DOT_VERSION > 0)
4478     const bool full_folding = TRUE; /* This variable is here so we can easily
4479                                        move to more generality later */
4480 #else
4481     const bool full_folding = FALSE;
4482 #endif
4483     const U8 flags = ( full_folding      ? FOLD_FLAGS_FULL   : 0 )
4484 #ifdef USE_LOCALE_CTYPE
4485                    | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4486 #endif
4487     ;
4488
4489     /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4490      * You are welcome(?) -Hugmeir
4491      */
4492
4493     SvGETMAGIC(source);
4494
4495     dest = TARG;
4496
4497     if (SvOK(source)) {
4498         s = (const U8*)SvPV_nomg_const(source, len);
4499     } else {
4500         if (ckWARN(WARN_UNINITIALIZED))
4501             report_uninit(source);
4502         s = (const U8*)"";
4503         len = 0;
4504     }
4505
4506     min = len + 1;
4507
4508     SvUPGRADE(dest, SVt_PV);
4509     d = (U8*)SvGROW(dest, min);
4510     (void)SvPOK_only(dest);
4511
4512     SETs(dest);
4513
4514     send = s + len;
4515     if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4516         while (s < send) {
4517             const STRLEN u = UTF8SKIP(s);
4518             STRLEN ulen;
4519
4520             _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4521
4522             if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4523                 const UV o = d - (U8*)SvPVX_const(dest);
4524                 d = o + (U8*) SvGROW(dest, min);
4525             }
4526
4527             Copy(tmpbuf, d, ulen, U8);
4528             d += ulen;
4529             s += u;
4530         }
4531         SvUTF8_on(dest);
4532     } /* Unflagged string */
4533     else if (len) {
4534 #ifdef USE_LOCALE_CTYPE
4535         if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4536             if (IN_UTF8_CTYPE_LOCALE) {
4537                 goto do_uni_folding;
4538             }
4539             _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4540             for (; s < send; d++, s++)
4541                 *d = (U8) toFOLD_LC(*s);
4542         }
4543         else
4544 #endif
4545         if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4546             for (; s < send; d++, s++)
4547                 *d = toFOLD(*s);
4548         }
4549         else {
4550 #ifdef USE_LOCALE_CTYPE
4551       do_uni_folding:
4552 #endif
4553             /* For ASCII and the Latin-1 range, there's only two troublesome
4554              * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4555              * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4556              * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4557              * For the rest, the casefold is their lowercase.  */
4558             for (; s < send; d++, s++) {
4559                 if (*s == MICRO_SIGN) {
4560                     /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4561                      * which is outside of the latin-1 range. There's a couple
4562                      * of ways to deal with this -- khw discusses them in
4563                      * pp_lc/uc, so go there :) What we do here is upgrade what
4564                      * we had already casefolded, then enter an inner loop that
4565                      * appends the rest of the characters as UTF-8. */
4566                     len = d - (U8*)SvPVX_const(dest);
4567                     SvCUR_set(dest, len);
4568                     len = sv_utf8_upgrade_flags_grow(dest,
4569                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4570                                                 /* The max expansion for latin1
4571                                                  * chars is 1 byte becomes 2 */
4572                                                 (send -s) * 2 + 1);
4573                     d = (U8*)SvPVX(dest) + len;
4574
4575                     Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4576                     d += small_mu_len;
4577                     s++;
4578                     for (; s < send; s++) {
4579                         STRLEN ulen;
4580                         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4581                         if UVCHR_IS_INVARIANT(fc) {
4582                             if (full_folding
4583                                 && *s == LATIN_SMALL_LETTER_SHARP_S)
4584                             {
4585                                 *d++ = 's';
4586                                 *d++ = 's';
4587                             }
4588                             else
4589                                 *d++ = (U8)fc;
4590                         }
4591                         else {
4592                             Copy(tmpbuf, d, ulen, U8);
4593                             d += ulen;
4594                         }
4595                     }
4596                     break;
4597                 }
4598                 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4599                     /* Under full casefolding, LATIN SMALL LETTER SHARP S
4600                      * becomes "ss", which may require growing the SV. */
4601                     if (SvLEN(dest) < ++min) {
4602                         const UV o = d - (U8*)SvPVX_const(dest);
4603                         d = o + (U8*) SvGROW(dest, min);
4604                      }
4605                     *(d)++ = 's';
4606                     *d = 's';
4607                 }
4608                 else { /* If it's not one of those two, the fold is their lower
4609                           case */
4610                     *d = toLOWER_LATIN1(*s);
4611                 }
4612              }
4613         }
4614     }
4615     *d = '\0';
4616     SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4617
4618 #ifdef USE_LOCALE_CTYPE
4619     if (IN_LC_RUNTIME(LC_CTYPE)) {
4620         TAINT;
4621         SvTAINTED_on(dest);
4622     }
4623 #endif
4624     if (SvTAINTED(source))
4625         SvTAINT(dest);
4626     SvSETMAGIC(dest);
4627     RETURN;
4628 }
4629
4630 /* Arrays. */
4631
4632 PP(pp_aslice)
4633 {
4634     dSP; dMARK; dORIGMARK;
4635     AV *const av = MUTABLE_AV(POPs);
4636     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4637
4638     if (SvTYPE(av) == SVt_PVAV) {
4639         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4640         bool can_preserve = FALSE;
4641
4642         if (localizing) {
4643             MAGIC *mg;
4644             HV *stash;
4645
4646             can_preserve = SvCANEXISTDELETE(av);
4647         }
4648
4649         if (lval && localizing) {
4650             SV **svp;
4651             SSize_t max = -1;
4652             for (svp = MARK + 1; svp <= SP; svp++) {
4653                 const SSize_t elem = SvIV(*svp);
4654                 if (elem > max)
4655                     max = elem;
4656             }
4657             if (max > AvMAX(av))
4658                 av_extend(av, max);
4659         }
4660
4661         while (++MARK <= SP) {
4662             SV **svp;
4663             SSize_t elem = SvIV(*MARK);
4664             bool preeminent = TRUE;
4665
4666             if (localizing && can_preserve) {
4667                 /* If we can determine whether the element exist,
4668                  * Try to preserve the existenceness of a tied array
4669                  * element by using EXISTS and DELETE if possible.
4670                  * Fallback to FETCH and STORE otherwise. */
4671                 preeminent = av_exists(av, elem);
4672             }
4673
4674             svp = av_fetch(av, elem, lval);
4675             if (lval) {
4676                 if (!svp || !*svp)
4677                     DIE(aTHX_ PL_no_aelem, elem);
4678                 if (localizing) {
4679                     if (preeminent)
4680                         save_aelem(av, elem, svp);
4681                     else
4682                         SAVEADELETE(av, elem);
4683                 }
4684             }
4685             *MARK = svp ? *svp : &PL_sv_undef;
4686         }
4687     }
4688     if (GIMME_V != G_ARRAY) {
4689         MARK = ORIGMARK;
4690         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4691         SP = MARK;
4692     }
4693     RETURN;
4694 }
4695
4696 PP(pp_kvaslice)
4697 {
4698     dSP; dMARK;
4699     AV *const av = MUTABLE_AV(POPs);
4700     I32 lval = (PL_op->op_flags & OPf_MOD);
4701     SSize_t items = SP - MARK;
4702
4703     if (PL_op->op_private & OPpMAYBE_LVSUB) {
4704        const I32 flags = is_lvalue_sub();
4705        if (flags) {
4706            if (!(flags & OPpENTERSUB_INARGS))
4707                /* diag_listed_as: Can't modify %s in %s */
4708                Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4709            lval = flags;
4710        }
4711     }
4712
4713     MEXTEND(SP,items);
4714     while (items > 1) {
4715         *(MARK+items*2-1) = *(MARK+items);
4716         items--;
4717     }
4718     items = SP-MARK;
4719     SP += items;
4720
4721     while (++MARK <= SP) {
4722         SV **svp;
4723
4724         svp = av_fetch(av, SvIV(*MARK), lval);
4725         if (lval) {
4726             if (!svp || !*svp || *svp == &PL_sv_undef) {
4727                 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4728             }
4729             *MARK = sv_mortalcopy(*MARK);
4730         }
4731         *++MARK = svp ? *svp : &PL_sv_undef;
4732     }
4733     if (GIMME_V != G_ARRAY) {
4734         MARK = SP - items*2;
4735         *++MARK = items > 0 ? *SP : &PL_sv_undef;
4736         SP = MARK;
4737     }
4738     RETURN;
4739 }
4740
4741
4742 PP(pp_aeach)
4743 {
4744     dSP;
4745     AV *array = MUTABLE_AV(POPs);
4746     const U8 gimme = GIMME_V;
4747     IV *iterp = Perl_av_iter_p(aTHX_ array);
4748     const IV current = (*iterp)++;
4749
4750     if (current > av_tindex(array)) {
4751         *iterp = 0;
4752         if (gimme == G_SCALAR)
4753             RETPUSHUNDEF;
4754         else
4755             RETURN;
4756     }
4757
4758     EXTEND(SP, 2);
4759     mPUSHi(current);
4760     if (gimme == G_ARRAY) {
4761         SV **const element = av_fetch(array, current, 0);
4762         PUSHs(element ? *element : &PL_sv_undef);
4763     }
4764     RETURN;
4765 }
4766
4767 /* also used for: pp_avalues()*/
4768 PP(pp_akeys)
4769 {
4770     dSP;
4771     AV *array = MUTABLE_AV(POPs);
4772     const U8 gimme = GIMME_V;
4773
4774     *Perl_av_iter_p(aTHX_ array) = 0;
4775
4776     if (gimme == G_SCALAR) {
4777         dTARGET;
4778         PUSHi(av_tindex(array) + 1);
4779     }
4780     else if (gimme == G_ARRAY) {
4781       if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
4782         const I32 flags = is_lvalue_sub();
4783         if (flags && !(flags & OPpENTERSUB_INARGS))
4784             /* diag_listed_as: Can't modify %s in %s */
4785             Perl_croak(aTHX_
4786                       "Can't modify keys on array in list assignment");
4787       }
4788       {
4789         IV n = Perl_av_len(aTHX_ array);
4790         IV i;
4791
4792         EXTEND(SP, n + 1);
4793
4794         if (  PL_op->op_type == OP_AKEYS
4795            || (  PL_op->op_type == OP_AVHVSWITCH
4796               && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS  ))
4797         {
4798             for (i = 0;  i <= n;  i++) {
4799                 mPUSHi(i);
4800             }
4801         }
4802         else {
4803             for (i = 0;  i <= n;  i++) {
4804                 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4805                 PUSHs(elem ? *elem : &PL_sv_undef);
4806             }
4807         }
4808       }
4809     }
4810     RETURN;
4811 }
4812
4813 /* Associative arrays. */
4814
4815 PP(pp_each)
4816 {
4817     dSP;
4818     HV * hash = MUTABLE_HV(POPs);
4819     HE *entry;
4820     const U8 gimme = GIMME_V;
4821
4822     entry = hv_iternext(hash);
4823
4824     EXTEND(SP, 2);
4825     if (entry) {
4826         SV* const sv = hv_iterkeysv(entry);
4827         PUSHs(sv);
4828         if (gimme == G_ARRAY) {
4829             SV *val;
4830             val = hv_iterval(hash, entry);
4831             PUSHs(val);
4832         }
4833     }
4834     else if (gimme == G_SCALAR)
4835         RETPUSHUNDEF;
4836
4837     RETURN;
4838 }
4839
4840 STATIC OP *
4841 S_do_delete_local(pTHX)
4842 {
4843     dSP;
4844     const U8 gimme = GIMME_V;
4845     const MAGIC *mg;
4846     HV *stash;
4847     const bool sliced = !!(PL_op->op_private & OPpSLICE);
4848     SV **unsliced_keysv = sliced ? NULL : sp--;
4849     SV * const osv = POPs;
4850     SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4851     dORIGMARK;
4852     const bool tied = SvRMAGICAL(osv)
4853                             && mg_find((const SV *)osv, PERL_MAGIC_tied);
4854     const bool can_preserve = SvCANEXISTDELETE(osv);
4855     const U32 type = SvTYPE(osv);
4856     SV ** const end = sliced ? SP : unsliced_keysv;
4857
4858     if (type == SVt_PVHV) {                     /* hash element */
4859             HV * const hv = MUTABLE_HV(osv);
4860             while (++MARK <= end) {
4861                 SV * const keysv = *MARK;
4862                 SV *sv = NULL;
4863                 bool preeminent = TRUE;
4864                 if (can_preserve)
4865                     preeminent = hv_exists_ent(hv, keysv, 0);
4866                 if (tied) {
4867                     HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4868                     if (he)
4869                         sv = HeVAL(he);
4870                     else
4871                         preeminent = FALSE;
4872                 }
4873                 else {
4874                     sv = hv_delete_ent(hv, keysv, 0, 0);
4875                     if (preeminent)
4876                         SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4877                 }
4878                 if (preeminent) {
4879                     if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4880                     save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4881                     if (tied) {
4882                         *MARK = sv_mortalcopy(sv);
4883                         mg_clear(sv);
4884                     } else
4885                         *MARK = sv;
4886                 }
4887                 else {
4888                     SAVEHDELETE(hv, keysv);
4889                     *MARK = &PL_sv_undef;
4890                 }
4891             }
4892     }
4893     else if (type == SVt_PVAV) {                  /* array element */
4894             if (PL_op->op_flags & OPf_SPECIAL) {
4895                 AV * const av = MUTABLE_AV(osv);
4896                 while (++MARK <= end) {
4897                     SSize_t idx = SvIV(*MARK);
4898                     SV *sv = NULL;
4899                     bool preeminent = TRUE;
4900                     if (can_preserve)
4901                         preeminent = av_exists(av, idx);
4902                     if (tied) {
4903                         SV **svp = av_fetch(av, idx, 1);
4904                         if (svp)
4905                             sv = *svp;
4906                         else
4907                             preeminent = FALSE;
4908                     }
4909                     else {
4910                         sv = av_delete(av, idx, 0);
4911                         if (preeminent)
4912                            SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4913                     }
4914                     if (preeminent) {
4915                         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4916                         if (tied) {
4917                             *MARK = sv_mortalcopy(sv);
4918                             mg_clear(sv);
4919                         } else
4920                             *MARK = sv;
4921                     }
4922                     else {
4923                         SAVEADELETE(av, idx);
4924                         *MARK = &PL_sv_undef;
4925                     }
4926                 }
4927             }
4928             else
4929                 DIE(aTHX_ "panic: avhv_delete no longer supported");
4930     }
4931     else
4932             DIE(aTHX_ "Not a HASH reference");
4933     if (sliced) {
4934         if (gimme == G_VOID)
4935             SP = ORIGMARK;
4936         else if (gimme == G_SCALAR) {
4937             MARK = ORIGMARK;
4938             if (SP > MARK)
4939                 *++MARK = *SP;
4940             else
4941                 *++MARK = &PL_sv_undef;
4942             SP = MARK;
4943         }
4944     }
4945     else if (gimme != G_VOID)
4946         PUSHs(*unsliced_keysv);
4947
4948     RETURN;
4949 }
4950
4951 PP(pp_delete)
4952 {
4953     dSP;
4954     U8 gimme;
4955     I32 discard;
4956
4957     if (PL_op->op_private & OPpLVAL_INTRO)
4958         return do_delete_local();
4959
4960     gimme = GIMME_V;
4961     discard = (gimme == G_VOID) ? G_DISCARD : 0;
4962
4963     if (PL_op->op_private & OPpSLICE) {
4964         dMARK; dORIGMARK;
4965         HV * const hv = MUTABLE_HV(POPs);
4966         const U32 hvtype = SvTYPE(hv);
4967         if (hvtype == SVt_PVHV) {                       /* hash element */
4968             while (++MARK <= SP) {
4969                 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4970                 *MARK = sv ? sv : &PL_sv_undef;
4971             }
4972         }
4973         else if (hvtype == SVt_PVAV) {                  /* array element */
4974             if (PL_op->op_flags & OPf_SPECIAL) {
4975                 while (++MARK <= SP) {
4976                     SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4977                     *MARK = sv ? sv : &PL_sv_undef;
4978                 }
4979             }
4980         }
4981         else
4982             DIE(aTHX_ "Not a HASH reference");
4983         if (discard)
4984             SP = ORIGMARK;
4985         else if (gimme == G_SCALAR) {
4986             MARK = ORIGMARK;
4987             if (SP > MARK)
4988                 *++MARK = *SP;
4989             else
4990                 *++MARK = &PL_sv_undef;
4991             SP = MARK;
4992         }
4993     }
4994     else {
4995         SV *keysv = POPs;
4996         HV * const hv = MUTABLE_HV(POPs);
4997         SV *sv = NULL;
4998         if (SvTYPE(hv) == SVt_PVHV)
4999             sv = hv_delete_ent(hv, keysv, discard, 0);
5000         else if (SvTYPE(hv) == SVt_PVAV) {
5001             if (PL_op->op_flags & OPf_SPECIAL)
5002                 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5003             else
5004                 DIE(aTHX_ "panic: avhv_delete no longer supported");
5005         }
5006         else
5007             DIE(aTHX_ "Not a HASH reference");
5008         if (!sv)
5009             sv = &PL_sv_undef;
5010         if (!discard)
5011             PUSHs(sv);
5012     }
5013     RETURN;
5014 }
5015
5016 PP(pp_exists)
5017 {
5018     dSP;
5019     SV *tmpsv;
5020     HV *hv;
5021
5022     if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5023         GV *gv;
5024         SV * const sv = POPs;
5025         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5026         if (cv)
5027             RETPUSHYES;
5028         if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5029             RETPUSHYES;
5030         RETPUSHNO;
5031     }
5032     tmpsv = POPs;
5033     hv = MUTABLE_HV(POPs);
5034     if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5035         if (hv_exists_ent(hv, tmpsv, 0))
5036             RETPUSHYES;
5037     }
5038     else if (SvTYPE(hv) == SVt_PVAV) {
5039         if (PL_op->op_flags & OPf_SPECIAL) {            /* array element */
5040             if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5041                 RETPUSHYES;
5042         }
5043     }
5044     else {
5045         DIE(aTHX_ "Not a HASH reference");
5046     }
5047     RETPUSHNO;
5048 }
5049
5050 PP(pp_hslice)
5051 {
5052     dSP; dMARK; dORIGMARK;
5053     HV * const hv = MUTABLE_HV(POPs);
5054     const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5055     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5056     bool can_preserve = FALSE;
5057
5058     if (localizing) {
5059         MAGIC *mg;
5060         HV *stash;
5061
5062         if (SvCANEXISTDELETE(hv))
5063             can_preserve = TRUE;
5064     }
5065
5066     while (++MARK <= SP) {
5067         SV * const keysv = *MARK;
5068         SV **svp;
5069         HE *he;
5070         bool preeminent = TRUE;
5071
5072         if (localizing && can_preserve) {
5073             /* If we can determine whether the element exist,
5074              * try to preserve the existenceness of a tied hash
5075              * element by using EXISTS and DELETE if possible.
5076              * Fallback to FETCH and STORE otherwise. */
5077             preeminent = hv_exists_ent(hv, keysv, 0);
5078         }
5079
5080         he = hv_fetch_ent(hv, keysv, lval, 0);
5081         svp = he ? &HeVAL(he) : NULL;
5082
5083         if (lval) {
5084             if (!svp || !*svp || *svp == &PL_sv_undef) {
5085                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5086             }
5087             if (localizing) {
5088                 if (HvNAME_get(hv) && isGV(*svp))
5089                     save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5090                 else if (preeminent)
5091                     save_helem_flags(hv, keysv, svp,
5092                          (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5093                 else
5094                     SAVEHDELETE(hv, keysv);
5095             }
5096         }
5097         *MARK = svp && *svp ? *svp : &PL_sv_undef;
5098     }
5099     if (GIMME_V != G_ARRAY) {
5100         MARK = ORIGMARK;
5101         *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5102         SP = MARK;
5103     }
5104     RETURN;
5105 }
5106
5107 PP(pp_kvhslice)
5108 {
5109     dSP; dMARK;
5110     HV * const hv = MUTABLE_HV(POPs);
5111     I32 lval = (PL_op->op_flags & OPf_MOD);
5112     SSize_t items = SP - MARK;
5113
5114     if (PL_op->op_private & OPpMAYBE_LVSUB) {
5115        const I32 flags = is_lvalue_sub();
5116        if (flags) {
5117            if (!(flags & OPpENTERSUB_INARGS))
5118                /* diag_listed_as: Can't modify %s in %s */
5119                Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5120                                  GIMME_V == G_ARRAY ? "list" : "scalar");
5121            lval = flags;
5122        }
5123     }
5124
5125     MEXTEND(SP,items);
5126     while (items > 1) {
5127         *(MARK+items*2-1) = *(MARK+items);
5128         items--;
5129     }
5130     items = SP-MARK;
5131     SP += items;
5132
5133     while (++MARK <= SP) {
5134         SV * const keysv = *MARK;
5135         SV **svp;
5136         HE *he;
5137
5138         he = hv_fetch_ent(hv, keysv, lval, 0);
5139         svp = he ? &HeVAL(he) : NULL;
5140
5141         if (lval) {
5142             if (!svp || !*svp || *svp == &PL_sv_undef) {
5143                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5144             }
5145             *MARK = sv_mortalcopy(*MARK);
5146         }
5147         *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5148     }
5149     if (GIMME_V != G_ARRAY) {
5150         MARK = SP - items*2;
5151         *++MARK = items > 0 ? *SP : &PL_sv_undef;
5152         SP = MARK;
5153     }
5154     RETURN;
5155 }
5156
5157 /* List operators. */
5158
5159 PP(pp_list)
5160 {
5161     I32 markidx = POPMARK;
5162     if (GIMME_V != G_ARRAY) {
5163         SV **mark = PL_stack_base + markidx;
5164         dSP;
5165         if (++MARK <= SP)
5166             *MARK = *SP;                /* unwanted list, return last item */
5167         else
5168             *MARK = &PL_sv_undef;
5169         SP = MARK;
5170         PUTBACK;
5171     }
5172     return NORMAL;
5173 }
5174
5175 PP(pp_lslice)
5176 {
5177     dSP;
5178     SV ** const lastrelem = PL_stack_sp;
5179     SV ** const lastlelem = PL_stack_base + POPMARK;
5180     SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5181     SV ** const firstrelem = lastlelem + 1;
5182     const U8 mod = PL_op->op_flags & OPf_MOD;
5183
5184     const I32 max = lastrelem - lastlelem;
5185     SV **lelem;
5186
5187     if (GIMME_V != G_ARRAY) {
5188         if (lastlelem < firstlelem) {
5189             *firstlelem = &PL_sv_undef;
5190         }
5191         else {
5192             I32 ix = SvIV(*lastlelem);
5193             if (ix < 0)
5194                 ix += max;
5195             if (ix < 0 || ix >= max)
5196                 *firstlelem = &PL_sv_undef;
5197             else
5198                 *firstlelem = firstrelem[ix];
5199         }
5200         SP = firstlelem;
5201         RETURN;
5202     }
5203
5204     if (max == 0) {
5205         SP = firstlelem - 1;
5206         RETURN;
5207     }
5208
5209     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5210         I32 ix = SvIV(*lelem);
5211         if (ix < 0)
5212             ix += max;
5213         if (ix < 0 || ix >= max)
5214             *lelem = &PL_sv_undef;
5215         else {
5216             if (!(*lelem = firstrelem[ix]))
5217                 *lelem = &PL_sv_undef;
5218             else if (mod && SvPADTMP(*lelem)) {
5219                 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5220             }
5221         }
5222     }
5223     SP = lastlelem;
5224     RETURN;
5225 }
5226
5227 PP(pp_anonlist)
5228 {
5229     dSP; dMARK;
5230     const I32 items = SP - MARK;
5231     SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5232     SP = MARK;
5233     mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5234             ? newRV_noinc(av) : av);
5235     RETURN;
5236 }
5237
5238 PP(pp_anonhash)
5239 {
5240     dSP; dMARK; dORIGMARK;
5241     HV* const hv = newHV();
5242     SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5243                                     ? newRV_noinc(MUTABLE_SV(hv))
5244                                     : MUTABLE_SV(hv) );
5245
5246     while (MARK < SP) {
5247         SV * const key =
5248             (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5249         SV *val;
5250         if (MARK < SP)
5251         {
5252             MARK++;
5253             SvGETMAGIC(*MARK);
5254             val = newSV(0);
5255             sv_setsv_nomg(val, *MARK);
5256         }
5257         else
5258         {
5259             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5260             val = newSV(0);
5261         }
5262         (void)hv_store_ent(hv,key,val,0);
5263     }
5264     SP = ORIGMARK;
5265     XPUSHs(retval);
5266     RETURN;
5267 }
5268
5269 PP(pp_splice)
5270 {
5271     dSP; dMARK; dORIGMARK;
5272     int num_args = (SP - MARK);
5273     AV *ary = MUTABLE_AV(*++MARK);
5274     SV **src;
5275     SV **dst;
5276     SSize_t i;
5277     SSize_t offset;
5278     SSize_t length;
5279     SSize_t newlen;
5280     SSize_t after;
5281     SSize_t diff;
5282     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5283
5284     if (mg) {
5285         return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5286                                     GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5287                                     sp - mark);
5288     }
5289
5290     SP++;
5291
5292     if (++MARK < SP) {
5293         offset = i = SvIV(*MARK);
5294         if (offset < 0)
5295             offset += AvFILLp(ary) + 1;
5296         if (offset < 0)
5297             DIE(aTHX_ PL_no_aelem, i);
5298         if (++MARK < SP) {
5299             length = SvIVx(*MARK++);
5300             if (length < 0) {
5301                 length += AvFILLp(ary) - offset + 1;
5302                 if (length < 0)
5303                     length = 0;
5304             }
5305         }
5306         else
5307             length = AvMAX(ary) + 1;            /* close enough to infinity */
5308     }
5309     else {
5310         offset = 0;
5311         length = AvMAX(ary) + 1;
5312     }
5313     if (offset > AvFILLp(ary) + 1) {
5314         if (num_args > 2)
5315             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5316         offset = AvFILLp(ary) + 1;
5317     }
5318     after = AvFILLp(ary) + 1 - (offset + length);
5319     if (after < 0) {                            /* not that much array */
5320         length += after;                        /* offset+length now in array */
5321         after = 0;
5322         if (!AvALLOC(ary))
5323             av_extend(ary, 0);
5324     }
5325
5326     /* At this point, MARK .. SP-1 is our new LIST */
5327
5328     newlen = SP - MARK;
5329     diff = newlen - length;
5330     if (newlen && !AvREAL(ary) && AvREIFY(ary))
5331         av_reify(ary);
5332
5333     /* make new elements SVs now: avoid problems if they're from the array */
5334     for (dst = MARK, i = newlen; i; i--) {
5335         SV * const h = *dst;
5336         *dst++ = newSVsv(h);
5337     }
5338
5339     if (diff < 0) {                             /* shrinking the area */
5340         SV **tmparyval = NULL;
5341         if (newlen) {
5342             Newx(tmparyval, newlen, SV*);       /* so remember insertion */
5343             Copy(MARK, tmparyval, newlen, SV*);
5344         }
5345
5346         MARK = ORIGMARK + 1;
5347         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5348             const bool real = cBOOL(AvREAL(ary));
5349             MEXTEND(MARK, length);
5350             if (real)
5351                 EXTEND_MORTAL(length);
5352             for (i = 0, dst = MARK; i < length; i++) {
5353                 if ((*dst = AvARRAY(ary)[i+offset])) {
5354                   if (real)
5355                     sv_2mortal(*dst);   /* free them eventually */
5356                 }
5357                 else
5358                     *dst = &PL_sv_undef;
5359                 dst++;
5360             }
5361             MARK += length - 1;
5362         }
5363         else {
5364             *MARK = AvARRAY(ary)[offset+length-1];
5365             if (AvREAL(ary)) {
5366                 sv_2mortal(*MARK);
5367                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5368                     SvREFCNT_dec(*dst++);       /* free them now */
5369             }
5370             if (!*MARK)
5371                 *MARK = &PL_sv_undef;
5372         }
5373         AvFILLp(ary) += diff;
5374
5375         /* pull up or down? */
5376
5377         if (offset < after) {                   /* easier to pull up */
5378             if (offset) {                       /* esp. if nothing to pull */
5379                 src = &AvARRAY(ary)[offset-1];
5380                 dst = src - diff;               /* diff is negative */
5381                 for (i = offset; i > 0; i--)    /* can't trust Copy */
5382                     *dst-- = *src--;
5383             }
5384             dst = AvARRAY(ary);
5385             AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5386             AvMAX(ary) += diff;
5387         }
5388         else {
5389             if (after) {                        /* anything to pull down? */
5390                 src = AvARRAY(ary) + offset + length;
5391                 dst = src + diff;               /* diff is negative */
5392                 Move(src, dst, after, SV*);
5393             }
5394             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5395                                                 /* avoid later double free */
5396         }
5397         i = -diff;
5398         while (i)
5399             dst[--i] = NULL;
5400
5401         if (newlen) {
5402             Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5403             Safefree(tmparyval);
5404         }
5405     }
5406     else {                                      /* no, expanding (or same) */
5407         SV** tmparyval = NULL;
5408         if (length) {
5409             Newx(tmparyval, length, SV*);       /* so remember deletion */
5410             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5411         }
5412
5413         if (diff > 0) {                         /* expanding */
5414             /* push up or down? */
5415             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5416                 if (offset) {
5417                     src = AvARRAY(ary);
5418                     dst = src - diff;
5419                     Move(src, dst, offset, SV*);
5420                 }
5421                 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5422                 AvMAX(ary) += diff;
5423                 AvFILLp(ary) += diff;
5424             }
5425             else {
5426                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
5427                     av_extend(ary, AvFILLp(ary) + diff);
5428                 AvFILLp(ary) += diff;
5429
5430                 if (after) {
5431                     dst = AvARRAY(ary) + AvFILLp(ary);
5432                     src = dst - diff;
5433                     for (i = after; i; i--) {
5434                         *dst-- = *src--;
5435                     }
5436                 }
5437             }
5438         }
5439
5440         if (newlen) {
5441             Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5442         }
5443
5444         MARK = ORIGMARK + 1;
5445         if (GIMME_V == G_ARRAY) {               /* copy return vals to stack */
5446             if (length) {
5447                 const bool real = cBOOL(AvREAL(ary));
5448                 if (real)
5449                     EXTEND_MORTAL(length);
5450                 for (i = 0, dst = MARK; i < length; i++) {
5451                     if ((*dst = tmparyval[i])) {
5452                       if (real)
5453                         sv_2mortal(*dst);       /* free them eventually */
5454                     }
5455                     else *dst = &PL_sv_undef;
5456                     dst++;
5457                 }
5458             }
5459             MARK += length - 1;
5460         }
5461         else if (length--) {
5462             *MARK = tmparyval[length];
5463             if (AvREAL(ary)) {
5464                 sv_2mortal(*MARK);
5465                 while (length-- > 0)
5466                     SvREFCNT_dec(tmparyval[length]);
5467             }
5468             if (!*MARK)
5469                 *MARK = &PL_sv_undef;
5470         }
5471         else
5472             *MARK = &PL_sv_undef;
5473         Safefree(tmparyval);
5474     }
5475
5476     if (SvMAGICAL(ary))
5477         mg_set(MUTABLE_SV(ary));
5478
5479     SP = MARK;
5480     RETURN;
5481 }
5482
5483 PP(pp_push)
5484 {
5485     dSP; dMARK; dORIGMARK; dTARGET;
5486     AV * const ary = MUTABLE_AV(*++MARK);
5487     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5488
5489     if (mg) {
5490         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5491         PUSHMARK(MARK);
5492         PUTBACK;
5493         ENTER_with_name("call_PUSH");
5494         call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5495         LEAVE_with_name("call_PUSH");
5496         /* SPAGAIN; not needed: SP is assigned to immediately below */
5497     }
5498     else {
5499         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5500          * only need to save locally, not on the save stack */
5501         U16 old_delaymagic = PL_delaymagic;
5502
5503         if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5504         PL_delaymagic = DM_DELAY;
5505         for (++MARK; MARK <= SP; MARK++) {
5506             SV *sv;
5507             if (*MARK) SvGETMAGIC(*MARK);
5508             sv = newSV(0);
5509             if (*MARK)
5510                 sv_setsv_nomg(sv, *MARK);
5511             av_store(ary, AvFILLp(ary)+1, sv);
5512         }
5513         if (PL_delaymagic & DM_ARRAY_ISA)
5514             mg_set(MUTABLE_SV(ary));
5515         PL_delaymagic = old_delaymagic;
5516     }
5517     SP = ORIGMARK;
5518     if (OP_GIMME(PL_op, 0) != G_VOID) {
5519         PUSHi( AvFILL(ary) + 1 );
5520     }
5521     RETURN;
5522 }
5523
5524 /* also used for: pp_pop()*/
5525 PP(pp_shift)
5526 {
5527     dSP;
5528     AV * const av = PL_op->op_flags & OPf_SPECIAL
5529         ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5530     SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5531     EXTEND(SP, 1);
5532     assert (sv);
5533     if (AvREAL(av))
5534         (void)sv_2mortal(sv);
5535     PUSHs(sv);
5536     RETURN;
5537 }
5538
5539 PP(pp_unshift)
5540 {
5541     dSP; dMARK; dORIGMARK; dTARGET;
5542     AV *ary = MUTABLE_AV(*++MARK);
5543     const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5544
5545     if (mg) {
5546         *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5547         PUSHMARK(MARK);
5548         PUTBACK;
5549         ENTER_with_name("call_UNSHIFT");
5550         call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5551         LEAVE_with_name("call_UNSHIFT");
5552         /* SPAGAIN; not needed: SP is assigned to immediately below */
5553     }
5554     else {
5555         /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5556          * only need to save locally, not on the save stack */
5557         U16 old_delaymagic = PL_delaymagic;
5558         SSize_t i = 0;
5559
5560         av_unshift(ary, SP - MARK);
5561         PL_delaymagic = DM_DELAY;
5562         while (MARK < SP) {
5563             SV * const sv = newSVsv(*++MARK);
5564             (void)av_store(ary, i++, sv);
5565         }
5566         if (PL_delaymagic & DM_ARRAY_ISA)
5567             mg_set(MUTABLE_SV(ary));
5568         PL_delaymagic = old_delaymagic;
5569     }
5570     SP = ORIGMARK;
5571     if (OP_GIMME(PL_op, 0) != G_VOID) {
5572         PUSHi( AvFILL(ary) + 1 );
5573     }
5574     RETURN;
5575 }
5576
5577 PP(pp_reverse)
5578 {
5579     dSP; dMARK;
5580
5581     if (GIMME_V == G_ARRAY) {
5582         if (PL_op->op_private & OPpREVERSE_INPLACE) {
5583             AV *av;
5584
5585             /* See pp_sort() */
5586             assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5587             (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5588             av = MUTABLE_AV((*SP));
5589             /* In-place reversing only happens in void context for the array
5590              * assignment. We don't need to push anything on the stack. */
5591             SP = MARK;
5592
5593             if (SvMAGICAL(av)) {
5594                 SSize_t i, j;
5595                 SV *tmp = sv_newmortal();
5596                 /* For SvCANEXISTDELETE */
5597                 HV *stash;
5598                 const MAGIC *mg;
5599                 bool can_preserve = SvCANEXISTDELETE(av);
5600
5601                 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5602                     SV *begin, *end;
5603
5604                     if (can_preserve) {
5605                         if (!av_exists(av, i)) {
5606                             if (av_exists(av, j)) {
5607                                 SV *sv = av_delete(av, j, 0);
5608                                 begin = *av_fetch(av, i, TRUE);
5609                                 sv_setsv_mg(begin, sv);
5610                             }
5611                             continue;
5612                         }
5613                         else if (!av_exists(av, j)) {
5614                             SV *sv = av_delete(av, i, 0);
5615                             end = *av_fetch(av, j, TRUE);
5616                             sv_setsv_mg(end, sv);
5617                             continue;
5618                         }
5619                     }
5620
5621                     begin = *av_fetch(av, i, TRUE);
5622                     end   = *av_fetch(av, j, TRUE);
5623                     sv_setsv(tmp,      begin);
5624                     sv_setsv_mg(begin, end);
5625                     sv_setsv_mg(end,   tmp);
5626                 }
5627             }
5628             else {
5629                 SV **begin = AvARRAY(av);
5630
5631                 if (begin) {
5632                     SV **end   = begin + AvFILLp(av);
5633
5634                     while (begin < end) {
5635                         SV * const tmp = *begin;
5636                         *begin++ = *end;
5637                         *end--   = tmp;
5638                     }
5639                 }
5640             }
5641         }
5642         else {
5643             SV **oldsp = SP;
5644             MARK++;
5645             while (MARK < SP) {
5646                 SV * const tmp = *MARK;
5647                 *MARK++ = *SP;
5648                 *SP--   = tmp;
5649             }
5650             /* safe as long as stack cannot get extended in the above */
5651             SP = oldsp;
5652         }
5653     }
5654     else {
5655         char *up;
5656         char *down;
5657         I32 tmp;
5658         dTARGET;
5659         STRLEN len;
5660
5661         SvUTF8_off(TARG);                               /* decontaminate */
5662         if (SP - MARK > 1)
5663             do_join(TARG, &PL_sv_no, MARK, SP);
5664         else {
5665             sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
5666         }
5667
5668         up = SvPV_force(TARG, len);
5669         if (len > 1) {
5670             if (DO_UTF8(TARG)) {        /* first reverse each character */
5671                 U8* s = (U8*)SvPVX(TARG);
5672                 const U8* send = (U8*)(s + len);
5673                 while (s < send) {
5674                     if (UTF8_IS_INVARIANT(*s)) {
5675                         s++;
5676                         continue;
5677                     }
5678                     else {
5679                         if (!utf8_to_uvchr_buf(s, send, 0))
5680                             break;
5681                         up = (char*)s;
5682                         s += UTF8SKIP(s);
5683                         down = (char*)(s - 1);
5684                         /* reverse this character */
5685                         while (down > up) {
5686                             tmp = *up;
5687                             *up++ = *down;
5688                             *down-- = (char)tmp;
5689                         }
5690                     }
5691                 }
5692                 up = SvPVX(TARG);
5693             }
5694             down = SvPVX(TARG) + len - 1;
5695             while (down > up) {
5696                 tmp = *up;
5697                 *up++ = *down;
5698                 *down-- = (char)tmp;
5699             }
5700             (void)SvPOK_only_UTF8(TARG);
5701         }
5702         SP = MARK + 1;
5703         SETTARG;
5704     }
5705     RETURN;
5706 }
5707
5708 PP(pp_split)
5709 {
5710     dSP; dTARG;
5711     AV *ary = (   (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5712                && (PL_op->op_flags & OPf_STACKED))      /* @{expr} = split */
5713                ? (AV *)POPs : NULL;
5714     IV limit = POPi;                    /* note, negative is forever */
5715     SV * const sv = POPs;
5716     STRLEN len;
5717     const char *s = SvPV_const(sv, len);
5718     const bool do_utf8 = DO_UTF8(sv);
5719     const char *strend = s + len;
5720     PMOP *pm = cPMOPx(PL_op);
5721     REGEXP *rx;
5722     SV *dstr;
5723     const char *m;
5724     SSize_t iters = 0;
5725     const STRLEN slen = do_utf8
5726                         ? utf8_length((U8*)s, (U8*)strend)
5727                         : (STRLEN)(strend - s);
5728     SSize_t maxiters = slen + 10;
5729     I32 trailing_empty = 0;
5730     const char *orig;
5731     const IV origlimit = limit;
5732     I32 realarray = 0;
5733     I32 base;
5734     const U8 gimme = GIMME_V;
5735     bool gimme_scalar;
5736     I32 oldsave = PL_savestack_ix;
5737     U32 make_mortal = SVs_TEMP;
5738     bool multiline = 0;
5739     MAGIC *mg = NULL;
5740
5741     rx = PM_GETRE(pm);
5742
5743     TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5744              (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5745
5746     /* handle @ary = split(...) optimisation */
5747     if (PL_op->op_private & OPpSPLIT_ASSIGN) {
5748         if (!(PL_op->op_flags & OPf_STACKED)) {
5749             if (PL_op->op_private & OPpSPLIT_LEX) {
5750                 if (PL_op->op_private & OPpLVAL_INTRO)
5751                     SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5752                 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
5753             }
5754             else {
5755                 GV *gv =
5756 #ifdef USE_ITHREADS
5757                         MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
5758 #else
5759                         pm->op_pmreplrootu.op_pmtargetgv;
5760 #endif
5761                 if (PL_op->op_private & OPpLVAL_INTRO)
5762                     ary = save_ary(gv);
5763                 else
5764                     ary = GvAVn(gv);
5765             }
5766             /* skip anything pushed by OPpLVAL_INTRO above */
5767             oldsave = PL_savestack_ix;
5768         }
5769
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
5794     base = SP - PL_stack_base;
5795     orig = s;
5796     if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5797         if (do_utf8) {
5798             while (isSPACE_utf8(s))
5799                 s += UTF8SKIP(s);
5800         }
5801         else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5802             while (isSPACE_LC(*s))
5803                 s++;
5804         }
5805         else {
5806             while (isSPACE(*s))
5807                 s++;
5808         }
5809     }
5810     if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5811         multiline = 1;
5812     }
5813
5814     gimme_scalar = gimme == G_SCALAR && !ary;
5815
5816     if (!limit)
5817         limit = maxiters + 2;
5818     if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5819         while (--limit) {
5820             m = s;
5821             /* this one uses 'm' and is a negative test */
5822             if (do_utf8) {
5823                 while (m < strend && ! isSPACE_utf8(m) ) {
5824                     const int t = UTF8SKIP(m);
5825                     /* isSPACE_utf8 returns FALSE for malform utf8 */
5826                     if (strend - m < t)
5827                         m = strend;
5828                     else
5829                         m += t;
5830                 }
5831             }
5832             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5833             {
5834                 while (m < strend && !isSPACE_LC(*m))
5835                     ++m;
5836             } else {
5837                 while (m < strend && !isSPACE(*m))
5838                     ++m;
5839             }
5840             if (m >= strend)
5841                 break;
5842
5843             if (gimme_scalar) {
5844                 iters++;
5845                 if (m-s == 0)
5846                     trailing_empty++;
5847                 else
5848                     trailing_empty = 0;
5849             } else {
5850                 dstr = newSVpvn_flags(s, m-s,
5851                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5852                 XPUSHs(dstr);
5853             }
5854
5855             /* skip the whitespace found last */
5856             if (do_utf8)
5857                 s = m + UTF8SKIP(m);
5858             else
5859                 s = m + 1;
5860
5861             /* this one uses 's' and is a positive test */
5862             if (do_utf8) {
5863                 while (s < strend && isSPACE_utf8(s) )
5864                     s +=  UTF8SKIP(s);
5865             }
5866             else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5867             {
5868                 while (s < strend && isSPACE_LC(*s))
5869                     ++s;
5870             } else {
5871                 while (s < strend && isSPACE(*s))
5872                     ++s;
5873             }
5874         }
5875     }
5876     else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5877         while (--limit) {
5878             for (m = s; m < strend && *m != '\n'; m++)
5879                 ;
5880             m++;
5881             if (m >= strend)
5882                 break;
5883
5884             if (gimme_scalar) {
5885                 iters++;
5886                 if (m-s == 0)
5887                     trailing_empty++;
5888                 else
5889                     trailing_empty = 0;
5890             } else {
5891                 dstr = newSVpvn_flags(s, m-s,
5892                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5893                 XPUSHs(dstr);
5894             }
5895             s = m;
5896         }
5897     }
5898     else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5899         /*
5900           Pre-extend the stack, either the number of bytes or
5901           characters in the string or a limited amount, triggered by:
5902
5903           my ($x, $y) = split //, $str;
5904             or
5905           split //, $str, $i;
5906         */
5907         if (!gimme_scalar) {
5908             const IV items = limit - 1;
5909             /* setting it to -1 will trigger a panic in EXTEND() */
5910             const SSize_t sslen = slen > SSize_t_MAX ?  -1 : (SSize_t)slen;
5911             if (items >=0 && items < sslen)
5912                 EXTEND(SP, items);
5913             else
5914                 EXTEND(SP, sslen);
5915         }
5916
5917         if (do_utf8) {
5918             while (--limit) {
5919                 /* keep track of how many bytes we skip over */
5920                 m = s;
5921                 s += UTF8SKIP(s);
5922                 if (gimme_scalar) {
5923                     iters++;
5924                     if (s-m == 0)
5925                         trailing_empty++;
5926                     else
5927                         trailing_empty = 0;
5928                 } else {
5929                     dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5930
5931                     PUSHs(dstr);
5932                 }
5933
5934                 if (s >= strend)
5935                     break;
5936             }
5937         } else {
5938             while (--limit) {
5939                 if (gimme_scalar) {
5940                     iters++;
5941                 } else {
5942                     dstr = newSVpvn(s, 1);
5943
5944
5945                     if (make_mortal)
5946                         sv_2mortal(dstr);
5947
5948                     PUSHs(dstr);
5949                 }
5950
5951                 s++;
5952
5953                 if (s >= strend)
5954                     break;
5955             }
5956         }
5957     }
5958     else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5959              (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5960              && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5961              && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5962         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5963         SV * const csv = CALLREG_INTUIT_STRING(rx);
5964
5965         len = RX_MINLENRET(rx);
5966         if (len == 1 && !RX_UTF8(rx) && !tail) {
5967             const char c = *SvPV_nolen_const(csv);
5968             while (--limit) {
5969                 for (m = s; m < strend && *m != c; m++)
5970                     ;
5971                 if (m >= strend)
5972                     break;
5973                 if (gimme_scalar) {
5974                     iters++;
5975                     if (m-s == 0)
5976                         trailing_empty++;
5977                     else
5978                         trailing_empty = 0;
5979                 } else {
5980                     dstr = newSVpvn_flags(s, m-s,
5981                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5982                     XPUSHs(dstr);
5983                 }
5984                 /* The rx->minlen is in characters but we want to step
5985                  * s ahead by bytes. */
5986                 if (do_utf8)
5987                     s = (char*)utf8_hop((U8*)m, len);
5988                 else
5989                     s = m + len; /* Fake \n at the end */
5990             }
5991         }
5992         else {
5993             while (s < strend && --limit &&
5994               (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5995                              csv, multiline ? FBMrf_MULTILINE : 0)) )
5996             {
5997                 if (gimme_scalar) {
5998                     iters++;
5999                     if (m-s == 0)
6000                         trailing_empty++;
6001                     else
6002                         trailing_empty = 0;
6003                 } else {
6004                     dstr = newSVpvn_flags(s, m-s,
6005                                          (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6006                     XPUSHs(dstr);
6007                 }
6008                 /* The rx->minlen is in characters but we want to step
6009                  * s ahead by bytes. */
6010                 if (do_utf8)
6011                     s = (char*)utf8_hop((U8*)m, len);
6012                 else
6013                     s = m + len; /* Fake \n at the end */
6014             }
6015         }
6016     }
6017     else {
6018         maxiters += slen * RX_NPARENS(rx);
6019         while (s < strend && --limit)
6020         {
6021             I32 rex_return;
6022             PUTBACK;
6023             rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6024                                      sv, NULL, 0);
6025             SPAGAIN;
6026             if (rex_return == 0)
6027                 break;
6028             TAINT_IF(RX_MATCH_TAINTED(rx));
6029             /* we never pass the REXEC_COPY_STR flag, so it should
6030              * never get copied */
6031             assert(!RX_MATCH_COPIED(rx));
6032             m = RX_OFFS(rx)[0].start + orig;
6033
6034             if (gimme_scalar) {
6035                 iters++;
6036                 if (m-s == 0)
6037                     trailing_empty++;
6038                 else
6039                     trailing_empty = 0;
6040             } else {
6041                 dstr = newSVpvn_flags(s, m-s,
6042                                       (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6043                 XPUSHs(dstr);
6044             }
6045             if (RX_NPARENS(rx)) {
6046                 I32 i;
6047                 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6048                     s = RX_OFFS(rx)[i].start + orig;
6049                     m = RX_OFFS(rx)[i].end + orig;
6050
6051                     /* japhy (07/27/01) -- the (m && s) test doesn't catch
6052                        parens that didn't match -- they should be set to
6053                        undef, not the empty string */
6054                     if (gimme_scalar) {
6055                         iters++;
6056                         if (m-s == 0)
6057                             trailing_empty++;
6058                         else
6059                             trailing_empty = 0;
6060                     } else {
6061                         if (m >= orig && s >= orig) {
6062                             dstr = newSVpvn_flags(s, m-s,
6063                                                  (do_utf8 ? SVf_UTF8 : 0)
6064                                                   | make_mortal);
6065                         }
6066                         else
6067                             dstr = &PL_sv_undef;  /* undef, not "" */
6068                         XPUSHs(dstr);
6069                     }
6070
6071                 }
6072             }
6073             s = RX_OFFS(rx)[0].end + orig;
6074         }
6075     }
6076
6077     if (!gimme_scalar) {
6078         iters = (SP - PL_stack_base) - base;
6079     }
6080     if (iters > maxiters)
6081         DIE(aTHX_ "Split loop");
6082
6083     /* keep field after final delim? */
6084     if (s < strend || (iters && origlimit)) {
6085         if (!gimme_scalar) {
6086             const STRLEN l = strend - s;
6087             dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6088             XPUSHs(dstr);
6089         }
6090         iters++;
6091     }
6092     else if (!origlimit) {
6093         if (gimme_scalar) {
6094             iters -= trailing_empty;
6095         } else {
6096             while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6097                 if (TOPs && !make_mortal)
6098                     sv_2mortal(TOPs);
6099                 *SP-- = &PL_sv_undef;
6100                 iters--;
6101             }
6102         }
6103     }
6104
6105     PUTBACK;
6106     LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6107     SPAGAIN;
6108     if (realarray) {
6109         if (!mg) {
6110             if (SvSMAGICAL(ary)) {
6111                 PUTBACK;
6112                 mg_set(MUTABLE_SV(ary));
6113                 SPAGAIN;
6114             }
6115             if (gimme == G_ARRAY) {
6116                 EXTEND(SP, iters);
6117                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6118                 SP += iters;
6119                 RETURN;
6120             }
6121         }
6122         else {
6123             PUTBACK;
6124             ENTER_with_name("call_PUSH");
6125             call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6126             LEAVE_with_name("call_PUSH");
6127             SPAGAIN;
6128             if (gimme == G_ARRAY) {
6129                 SSize_t i;
6130                 /* EXTEND should not be needed - we just popped them */
6131                 EXTEND(SP, iters);
6132                 for (i=0; i < iters; i++) {
6133                     SV **svp = av_fetch(ary, i, FALSE);
6134                     PUSHs((svp) ? *svp : &PL_sv_undef);
6135                 }
6136                 RETURN;
6137             }
6138         }
6139     }
6140     else {
6141         if (gimme == G_ARRAY)
6142             RETURN;
6143     }
6144
6145     GETTARGET;
6146     PUSHi(iters);
6147     RETURN;
6148 }
6149
6150 PP(pp_once)
6151 {
6152     dSP;
6153     SV *const sv = PAD_SVl(PL_op->op_targ);
6154
6155     if (SvPADSTALE(sv)) {
6156         /* First time. */
6157         SvPADSTALE_off(sv);
6158         RETURNOP(cLOGOP->op_other);
6159     }
6160     RETURNOP(cLOGOP->op_next);
6161 }
6162
6163 PP(pp_lock)
6164 {
6165     dSP;
6166     dTOPss;
6167     SV *retsv = sv;
6168     SvLOCK(sv);
6169     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6170      || SvTYPE(retsv) == SVt_PVCV) {
6171         retsv = refto(retsv);
6172     }
6173     SETs(retsv);
6174     RETURN;
6175 }
6176
6177
6178 /* used for: pp_padany(), pp_custom(); plus any system ops
6179  * that aren't implemented on a particular platform */
6180
6181 PP(unimplemented_op)
6182 {
6183     const Optype op_type = PL_op->op_type;
6184     /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6185        with out of range op numbers - it only "special" cases op_custom.
6186        Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6187        if we get here for a custom op then that means that the custom op didn't
6188        have an implementation. Given that OP_NAME() looks up the custom op
6189        by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6190        registers &PL_unimplemented_op as the address of their custom op.
6191        NULL doesn't generate a useful error message. "custom" does. */
6192     const char *const name = op_type >= OP_max
6193         ? "[out of range]" : PL_op_name[PL_op->op_type];
6194     if(OP_IS_SOCKET(op_type))
6195         DIE(aTHX_ PL_no_sock_func, name);
6196     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,  op_type);
6197 }
6198
6199 static void
6200 S_maybe_unwind_defav(pTHX)
6201 {
6202     if (CX_CUR()->cx_type & CXp_HASARGS) {
6203         PERL_CONTEXT *cx = CX_CUR();
6204
6205         assert(CxHASARGS(cx));
6206         cx_popsub_args(cx);
6207         cx->cx_type &= ~CXp_HASARGS;
6208     }
6209 }
6210
6211 /* For sorting out arguments passed to a &CORE:: subroutine */
6212 PP(pp_coreargs)
6213 {
6214     dSP;
6215     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6216     int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6217     AV * const at_ = GvAV(PL_defgv);
6218     SV **svp = at_ ? AvARRAY(at_) : NULL;
6219     I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6220     I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6221     bool seen_question = 0;
6222     const char *err = NULL;
6223     const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6224
6225     /* Count how many args there are first, to get some idea how far to
6226        extend the stack. */
6227     while (oa) {
6228         if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6229         maxargs++;
6230         if (oa & OA_OPTIONAL) seen_question = 1;
6231         if (!seen_question) minargs++;
6232         oa >>= 4;
6233     }
6234
6235     if(numargs < minargs) err = "Not enough";
6236     else if(numargs > maxargs) err = "Too many";
6237     if (err)
6238         /* diag_listed_as: Too many arguments for %s */
6239         Perl_croak(aTHX_
6240           "%s arguments for %s", err,
6241            opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6242         );
6243
6244     /* Reset the stack pointer.  Without this, we end up returning our own
6245        arguments in list context, in addition to the values we are supposed
6246        to return.  nextstate usually does this on sub entry, but we need
6247        to run the next op with the caller's hints, so we cannot have a
6248        nextstate. */
6249     SP = PL_stack_base + CX_CUR()->blk_oldsp;
6250
6251     if(!maxargs) RETURN;
6252
6253     /* We do this here, rather than with a separate pushmark op, as it has
6254        to come in between two things this function does (stack reset and
6255        arg pushing).  This seems the easiest way to do it. */
6256     if (pushmark) {
6257         PUTBACK;
6258         (void)Perl_pp_pushmark(aTHX);
6259     }
6260
6261     EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6262     PUTBACK; /* The code below can die in various places. */
6263
6264     oa = PL_opargs[opnum] >> OASHIFT;
6265     for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6266         whicharg++;
6267         switch (oa & 7) {
6268         case OA_SCALAR:
6269           try_defsv:
6270             if (!numargs && defgv && whicharg == minargs + 1) {
6271                 PUSHs(DEFSV);
6272             }
6273             else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6274             break;
6275         case OA_LIST:
6276             while (numargs--) {
6277                 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6278                 svp++;
6279             }
6280             RETURN;
6281         case OA_AVREF:
6282             if (!numargs) {
6283                 GV *gv;
6284                 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6285                     gv = PL_argvgv;
6286                 else {
6287                     S_maybe_unwind_defav(aTHX);
6288                     gv = PL_defgv;
6289                 }
6290                 PUSHs((SV *)GvAVn(gv));
6291                 break;
6292             }
6293             if (!svp || !*svp || !SvROK(*svp)
6294              || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6295                 DIE(aTHX_
6296                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6297                  "Type of arg %d to &CORE::%s must be array reference",
6298                   whicharg, PL_op_desc[opnum]
6299                 );
6300             PUSHs(SvRV(*svp));
6301             break;
6302         case OA_HVREF:
6303             if (!svp || !*svp || !SvROK(*svp)
6304              || (  SvTYPE(SvRV(*svp)) != SVt_PVHV
6305                 && (  opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6306                    || SvTYPE(SvRV(*svp)) != SVt_PVAV  )))
6307                 DIE(aTHX_
6308                 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6309                  "Type of arg %d to &CORE::%s must be hash%s reference",
6310                   whicharg, PL_op_desc[opnum],
6311                   opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6312                      ? ""
6313                      : " or array"
6314                 );
6315             PUSHs(SvRV(*svp));
6316             break;
6317         case OA_FILEREF:
6318             if (!numargs) PUSHs(NULL);
6319             else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6320                 /* no magic here, as the prototype will have added an extra
6321                    refgen and we just want what was there before that */
6322                 PUSHs(SvRV(*svp));
6323             else {
6324                 const bool constr = PL_op->op_private & whicharg;
6325                 PUSHs(S_rv2gv(aTHX_
6326                     svp && *svp ? *svp : &PL_sv_undef,
6327                     constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6328                     !constr
6329                 ));
6330             }
6331             break;
6332         case OA_SCALARREF:
6333           if (!numargs) goto try_defsv;
6334           else {
6335             const bool wantscalar =
6336                 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6337             if (!svp || !*svp || !SvROK(*svp)
6338                 /* We have to permit globrefs even for the \$ proto, as
6339                    *foo is indistinguishable from ${\*foo}, and the proto-
6340                    type permits the latter. */
6341              || SvTYPE(SvRV(*svp)) > (
6342                      wantscalar       ? SVt_PVLV
6343                    : opnum == OP_LOCK || opnum == OP_UNDEF
6344                                       ? SVt_PVCV
6345                    :                    SVt_PVHV
6346                 )
6347                )
6348                 DIE(aTHX_
6349                  "Type of arg %d to &CORE::%s must be %s",
6350                   whicharg, PL_op_name[opnum],
6351                   wantscalar
6352                     ? "scalar reference"
6353                     : opnum == OP_LOCK || opnum == OP_UNDEF
6354                        ? "reference to one of [$@%&*]"
6355                        : "reference to one of [$@%*]"
6356                 );
6357             PUSHs(SvRV(*svp));
6358             if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6359                 /* Undo @_ localisation, so that sub exit does not undo
6360                    part of our undeffing. */
6361                 S_maybe_unwind_defav(aTHX);
6362             }
6363           }
6364           break;
6365         default:
6366             DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6367         }
6368         oa = oa >> 4;
6369     }
6370
6371     RETURN;
6372 }
6373
6374 PP(pp_avhvswitch)
6375 {
6376     dVAR; dSP;
6377     return PL_ppaddr[
6378                 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6379                     + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6380            ](aTHX);
6381 }
6382
6383 PP(pp_runcv)
6384 {
6385     dSP;
6386     CV *cv;
6387     if (PL_op->op_private & OPpOFFBYONE) {
6388         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6389     }
6390     else cv = find_runcv(NULL);
6391     XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6392     RETURN;
6393 }
6394
6395 static void
6396 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6397                             const bool can_preserve)
6398 {
6399     const SSize_t ix = SvIV(keysv);
6400     if (can_preserve ? av_exists(av, ix) : TRUE) {
6401         SV ** const svp = av_fetch(av, ix, 1);
6402         if (!svp || !*svp)
6403             Perl_croak(aTHX_ PL_no_aelem, ix);
6404         save_aelem(av, ix, svp);
6405     }
6406     else
6407         SAVEADELETE(av, ix);
6408 }
6409
6410 static void
6411 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6412                             const bool can_preserve)
6413 {
6414     if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6415         HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6416         SV ** const svp = he ? &HeVAL(he) : NULL;
6417         if (!svp || !*svp)
6418             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6419         save_helem_flags(hv, keysv, svp, 0);
6420     }
6421     else
6422         SAVEHDELETE(hv, keysv);
6423 }
6424
6425 static void
6426 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6427 {
6428     if (type == OPpLVREF_SV) {
6429         save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6430         GvSV(gv) = 0;
6431     }
6432     else if (type == OPpLVREF_AV)
6433         /* XXX Inefficient, as it creates a new AV, which we are
6434                about to clobber.  */
6435         save_ary(gv);
6436     else {
6437         assert(type == OPpLVREF_HV);
6438         /* XXX Likewise inefficient.  */
6439         save_hash(gv);
6440     }
6441 }
6442
6443
6444 PP(pp_refassign)
6445 {
6446     dSP;
6447     SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6448     SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6449     dTOPss;
6450     const char *bad = NULL;
6451     const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6452     if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6453     switch (type) {
6454     case OPpLVREF_SV:
6455         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6456             bad = " SCALAR";
6457         break;
6458     case OPpLVREF_AV:
6459         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6460             bad = "n ARRAY";
6461         break;
6462     case OPpLVREF_HV:
6463         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6464             bad = " HASH";
6465         break;
6466     case OPpLVREF_CV:
6467         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6468             bad = " CODE";
6469     }
6470     if (bad)
6471         /* diag_listed_as: Assigned value is not %s reference */
6472         DIE(aTHX_ "Assigned value is not a%s reference", bad);
6473     {
6474     MAGIC *mg;
6475     HV *stash;
6476     switch (left ? SvTYPE(left) : 0) {
6477     case 0:
6478     {
6479         SV * const old = PAD_SV(ARGTARG);
6480         PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6481         SvREFCNT_dec(old);
6482         if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6483                 == OPpLVAL_INTRO)
6484             SAVECLEARSV(PAD_SVl(ARGTARG));
6485         break;
6486     }
6487     case SVt_PVGV:
6488         if (PL_op->op_private & OPpLVAL_INTRO) {
6489             S_localise_gv_slot(aTHX_ (GV *)left, type);
6490         }
6491         gv_setref(left, sv);
6492         SvSETMAGIC(left);
6493         break;
6494     case SVt_PVAV:
6495         assert(key);
6496         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6497             S_localise_aelem_lval(aTHX_ (AV *)left, key,
6498                                         SvCANEXISTDELETE(left));
6499         }
6500         av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6501         break;
6502     case SVt_PVHV:
6503         if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6504             assert(key);
6505             S_localise_helem_lval(aTHX_ (HV *)left, key,
6506                                         SvCANEXISTDELETE(left));
6507         }
6508         (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6509     }
6510     if (PL_op->op_flags & OPf_MOD)
6511         SETs(sv_2mortal(newSVsv(sv)));
6512     /* XXX else can weak references go stale before they are read, e.g.,
6513        in leavesub?  */
6514     RETURN;
6515     }
6516 }
6517
6518 PP(pp_lvref)
6519 {
6520     dSP;
6521     SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6522     SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6523     SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6524     MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6525                                    &PL_vtbl_lvref, (char *)elem,
6526                                    elem ? HEf_SVKEY : (I32)ARGTARG);
6527     mg->mg_private = PL_op->op_private;
6528     if (PL_op->op_private & OPpLVREF_ITER)
6529         mg->mg_flags |= MGf_PERSIST;
6530     if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6531       if (elem) {
6532         MAGIC *mg;
6533         HV *stash;
6534         assert(arg);
6535         {
6536             const bool can_preserve = SvCANEXISTDELETE(arg);
6537             if (SvTYPE(arg) == SVt_PVAV)
6538               S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6539             else
6540               S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6541         }
6542       }
6543       else if (arg) {
6544         S_localise_gv_slot(aTHX_ (GV *)arg,
6545                                  PL_op->op_private & OPpLVREF_TYPE);
6546       }
6547       else if (!(PL_op->op_private & OPpPAD_STATE))
6548         SAVECLEARSV(PAD_SVl(ARGTARG));
6549     }
6550     XPUSHs(ret);
6551     RETURN;
6552 }
6553
6554 PP(pp_lvrefslice)
6555 {
6556     dSP; dMARK;
6557     AV * const av = (AV *)POPs;
6558     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6559     bool can_preserve = FALSE;
6560
6561     if (UNLIKELY(localizing)) {
6562         MAGIC *mg;
6563         HV *stash;
6564         SV **svp;
6565
6566         can_preserve = SvCANEXISTDELETE(av);
6567
6568         if (SvTYPE(av) == SVt_PVAV) {
6569             SSize_t max = -1;
6570
6571             for (svp = MARK + 1; svp <= SP; svp++) {
6572                 const SSize_t elem = SvIV(*svp);
6573                 if (elem > max)
6574                     max = elem;
6575             }
6576             if (max > AvMAX(av))
6577                 av_extend(av, max);
6578         }
6579     }
6580
6581     while (++MARK <= SP) {
6582         SV * const elemsv = *MARK;
6583         if (SvTYPE(av) == SVt_PVAV)
6584             S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6585         else
6586             S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6587         *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6588         sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6589     }
6590     RETURN;
6591 }
6592
6593 PP(pp_lvavref)
6594 {
6595     if (PL_op->op_flags & OPf_STACKED)
6596         Perl_pp_rv2av(aTHX);
6597     else
6598         Perl_pp_padav(aTHX);
6599     {
6600         dSP;
6601         dTOPss;
6602         SETs(0); /* special alias marker that aassign recognises */
6603         XPUSHs(sv);
6604         RETURN;
6605     }
6606 }
6607
6608 PP(pp_anonconst)
6609 {
6610     dSP;
6611     dTOPss;
6612     SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6613                                         ? CopSTASH(PL_curcop)
6614                                         : NULL,
6615                                       NULL, SvREFCNT_inc_simple_NN(sv))));
6616     RETURN;
6617 }
6618
6619
6620 /* process one subroutine argument - typically when the sub has a signature:
6621  * introduce PL_curpad[op_targ] and assign to it the value
6622  *  for $:   (OPf_STACKED ? *sp : $_[N])
6623  *  for @/%: @_[N..$#_]
6624  *
6625  * It's equivalent to
6626  *    my $foo = $_[N];
6627  * or
6628  *    my $foo = (value-on-stack)
6629  * or
6630  *    my @foo = @_[N..$#_]
6631  * etc
6632  */
6633
6634 PP(pp_argelem)
6635 {
6636     dTARG;
6637     SV *val;
6638     SV ** padentry;
6639     OP *o = PL_op;
6640     AV *defav = GvAV(PL_defgv); /* @_ */
6641     IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6642     IV argc;
6643
6644     /* do 'my $var, @var or %var' action */
6645     padentry = &(PAD_SVl(o->op_targ));
6646     save_clearsv(padentry);
6647     targ = *padentry;
6648
6649     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6650         if (o->op_flags & OPf_STACKED) {
6651             dSP;
6652             val = POPs;
6653             PUTBACK;
6654         }
6655         else {
6656             SV **svp;
6657             /* should already have been checked */
6658             assert(ix >= 0);
6659 #if IVSIZE > PTRSIZE
6660             assert(ix <= SSize_t_MAX);
6661 #endif
6662
6663             svp = av_fetch(defav, ix, FALSE);
6664             val = svp ? *svp : &PL_sv_undef;
6665         }
6666
6667         /* $var = $val */
6668
6669         /* cargo-culted from pp_sassign */
6670         assert(TAINTING_get || !TAINT_get);
6671         if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6672             TAINT_NOT;
6673
6674         SvSetMagicSV(targ, val);
6675         return o->op_next;
6676     }
6677
6678     /* must be AV or HV */
6679
6680     assert(!(o->op_flags & OPf_STACKED));
6681     argc = ((IV)AvFILL(defav) + 1) - ix;
6682
6683     /* This is a copy of the relevant parts of pp_aassign().
6684      */
6685     if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6686         IV i;
6687
6688         if (AvFILL((AV*)targ) > -1) {
6689             /* target should usually be empty. If we get get
6690              * here, someone's been doing some weird closure tricks.
6691              * Make a copy of all args before clearing the array,
6692              * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6693              * elements. See similar code in pp_aassign.
6694              */
6695             for (i = 0; i < argc; i++) {
6696                 SV **svp = av_fetch(defav, ix + i, FALSE);
6697                 SV *newsv = newSV(0);
6698                 sv_setsv_flags(newsv,
6699                                 svp ? *svp : &PL_sv_undef,
6700                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6701                 if (!av_store(defav, ix + i, newsv))
6702                     SvREFCNT_dec_NN(newsv);
6703             }
6704             av_clear((AV*)targ);
6705         }
6706
6707         if (argc <= 0)
6708             return o->op_next;
6709
6710         av_extend((AV*)targ, argc);
6711
6712         i = 0;
6713         while (argc--) {
6714             SV *tmpsv;
6715             SV **svp = av_fetch(defav, ix + i, FALSE);
6716             SV *val = svp ? *svp : &PL_sv_undef;
6717             tmpsv = newSV(0);
6718             sv_setsv(tmpsv, val);
6719             av_store((AV*)targ, i++, tmpsv);
6720             TAINT_NOT;
6721         }
6722
6723     }
6724     else {
6725         IV i;
6726
6727         assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
6728
6729         if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
6730             /* see "target should usually be empty" comment above */
6731             for (i = 0; i < argc; i++) {
6732                 SV **svp = av_fetch(defav, ix + i, FALSE);
6733                 SV *newsv = newSV(0);
6734                 sv_setsv_flags(newsv,
6735                                 svp ? *svp : &PL_sv_undef,
6736                                 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6737                 if (!av_store(defav, ix + i, newsv))
6738                     SvREFCNT_dec_NN(newsv);
6739             }
6740             hv_clear((HV*)targ);
6741         }
6742
6743         if (argc <= 0)
6744             return o->op_next;
6745         assert(argc % 2 == 0);
6746
6747         i = 0;
6748         while (argc) {
6749             SV *tmpsv;
6750             SV **svp;
6751             SV *key;
6752             SV *val;
6753
6754             svp = av_fetch(defav, ix + i++, FALSE);
6755             key = svp ? *svp : &PL_sv_undef;
6756             svp = av_fetch(defav, ix + i++, FALSE);
6757             val = svp ? *svp : &PL_sv_undef;
6758
6759             argc -= 2;
6760             if (UNLIKELY(SvGMAGICAL(key)))
6761                 key = sv_mortalcopy(key);
6762             tmpsv = newSV(0);
6763             sv_setsv(tmpsv, val);
6764             hv_store_ent((HV*)targ, key, tmpsv, 0);
6765             TAINT_NOT;
6766         }
6767     }
6768
6769     return o->op_next;
6770 }
6771
6772 /* Handle a default value for one subroutine argument (typically as part
6773  * of a subroutine signature).
6774  * It's equivalent to
6775  *    @_ > op_targ ? $_[op_targ] : result_of(op_other)
6776  *
6777  * Intended to be used where op_next is an OP_ARGELEM
6778  *
6779  * We abuse the op_targ field slightly: it's an index into @_ rather than
6780  * into PL_curpad.
6781  */
6782
6783 PP(pp_argdefelem)
6784 {
6785     OP * const o = PL_op;
6786     AV *defav = GvAV(PL_defgv); /* @_ */
6787     IV ix = (IV)o->op_targ;
6788
6789     assert(ix >= 0);
6790 #if IVSIZE > PTRSIZE
6791     assert(ix <= SSize_t_MAX);
6792 #endif
6793
6794     if (AvFILL(defav) >= ix) {
6795         dSP;
6796         SV **svp = av_fetch(defav, ix, FALSE);
6797         SV  *val = svp ? *svp : &PL_sv_undef;
6798         XPUSHs(val);
6799         RETURN;
6800     }
6801     return cLOGOPo->op_other;
6802 }
6803
6804
6805
6806 /* Check a  a subs arguments - i.e. that it has the correct number of args
6807  * (and anything else we might think of in future). Typically used with
6808  * signatured subs.
6809  */
6810
6811 PP(pp_argcheck)
6812 {
6813     OP * const o       = PL_op;
6814     UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
6815     IV   params        = aux[0].iv;
6816     IV   opt_params    = aux[1].iv;
6817     char slurpy        = (char)(aux[2].iv);
6818     AV  *defav         = GvAV(PL_defgv); /* @_ */
6819     IV   argc;
6820     bool too_few;
6821
6822     assert(!SvMAGICAL(defav));
6823     argc = (AvFILLp(defav) + 1);
6824     too_few = (argc < (params - opt_params));
6825
6826     if (UNLIKELY(too_few || (!slurpy && argc > params)))
6827         /* diag_listed_as: Too few arguments for subroutine */
6828         /* diag_listed_as: Too many arguments for subroutine */
6829         Perl_croak_caller("Too %s arguments for subroutine",
6830                             too_few ? "few" : "many");
6831
6832     if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
6833         Perl_croak_caller("Odd name/value argument for subroutine");
6834
6835
6836     return NORMAL;
6837 }
6838
6839 /*
6840  * ex: set ts=8 sts=4 sw=4 et:
6841  */