pp.c

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