pp.c

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