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