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