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