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