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