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