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