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