pp.c

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