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