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