pp.c

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